From 3f00812e34c6c31ce054d01b50293809b6e7cde2 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Tue, 19 May 2026 11:33:36 -0700 Subject: [PATCH 01/32] Add model and declFxn handling from PdV work in nCompiler and CJP sidework. --- nimbleModel/DESCRIPTION | 8 +- nimbleModel/NAMESPACE | 1 + nimbleModel/R/declFxnBaseClass.R | 69 +++ nimbleModel/R/instructions.R | 140 +++++ nimbleModel/R/model.R | 4 +- nimbleModel/R/modelBaseClass.R | 90 +++ nimbleModel/R/nimbleModel.R | 511 ++++++++++++++++++ nimbleModel/R/nodeRules.R | 69 +-- nimbleModel/tests/testthat/test-nimbleModel.R | 279 ++++++++++ 9 files changed, 1104 insertions(+), 67 deletions(-) create mode 100644 nimbleModel/R/declFxnBaseClass.R create mode 100644 nimbleModel/R/instructions.R create mode 100644 nimbleModel/R/modelBaseClass.R create mode 100644 nimbleModel/R/nimbleModel.R create mode 100644 nimbleModel/tests/testthat/test-nimbleModel.R diff --git a/nimbleModel/DESCRIPTION b/nimbleModel/DESCRIPTION index 0f1462c..693a2ba 100644 --- a/nimbleModel/DESCRIPTION +++ b/nimbleModel/DESCRIPTION @@ -3,9 +3,9 @@ Title: What the Package Does (one line, title case) Version: 0.0.0.9000 Authors@R: person("First", "Last", email = "first.last@example.com", role = c("aut", "cre")) Description: What the package does (one paragraph). -Depends: R (>= 3.3.3) +Depends: R (>= 4.1.0) Imports: - methods,R6 + methods,R6,nCompiler License: What license is it under? Encoding: UTF-8 LazyData: true @@ -43,6 +43,10 @@ Collate: varRange.R varRules.R varStore.R + declFxnBaseClass.R + modelBaseClass.R + instructions.R + nimbleModel.R diff --git a/nimbleModel/NAMESPACE b/nimbleModel/NAMESPACE index 9f9aabf..57a7f59 100644 --- a/nimbleModel/NAMESPACE +++ b/nimbleModel/NAMESPACE @@ -1,5 +1,6 @@ import(methods) import(R6) +import(nCompiler) ## Some exports are for testing convenience and may not need to be exported. ## Classes: R6 classes are exported as regular objects diff --git a/nimbleModel/R/declFxnBaseClass.R b/nimbleModel/R/declFxnBaseClass.R new file mode 100644 index 0000000..d35aa9c --- /dev/null +++ b/nimbleModel/R/declFxnBaseClass.R @@ -0,0 +1,69 @@ +#' @export +declFxnBase_nClass <- nClass( + classname = "declFxnBase_nClass", + Cpublic = list( + ## model = 'modelBase_nClass', + ping = nFunction( + name = "ping", + function() {return(TRUE); returnType(logical())}, + compileInfo = list(virtual=TRUE) + ), + calculate = nFunction( + name = "calculate", + fun = function(instr = 'instr_nClass') { + ## TODO: how embed determination of vec and parallel cases here? + if(instr$type == 0) return(calc_0(instr)) + if(instr$type == 1) return(calc_1_seq(instr)) + if(instr$type == 2) return(calc_1_mat(instr)) + if(instr$type == 3) return(calc_1_matp(instr)) + return(0) ## Need to error trap/warn if unhandled type requested + }, returnType = 'numericScalar', + compileInfo = list(virtual=TRUE) + ), + ## TODO: for all these type-specific calculates, how do we call the methods of the declFxn_nClass object? + calc_0 = nFunction( + name = 'calc_0', + function(instr = 'instr_nClass') { + ## Presumably this will have access to derive class' `calc_one`? + return(calc_one(0)) ## calc_one will always has `idx` as arg? + }, returnType = 'numericScalar' + ), + calc_1_seq = nFunction( + name = 'calc_1_seq', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + calc_one(instr$values[[1]][1]+i) + return(logProb) + }, returnType = 'numericScalar' + ), + calc_1_mat = nFunction( + name = 'calc_1_mat', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + calc_one(instr$values[[1]][i]) + return(logProb) + }, returnType = 'numericScalar' + ), + calc_1_matp = nFunction( + name = 'calc_1_mat', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + calc_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + return(logProb) + }, returnType = 'numericScalar' + ) + ), + ## We haven't dealt with ensuring a virtual destructor when any method is virtual + ## For now I did it manually by editing the .h and .cpp + predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> + file.path("declFxnBase_nC")), + compileInfo=list(interface="full", + createFromR = FALSE, + exportName = "declFxnBase_nClass_new", + needed_units = list("nodeInstr_nClass"), + packageNames = c(uncompiled="declFxnBase_nClass_R", compiled="declFxnBase_nClass") + ) +) diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R new file mode 100644 index 0000000..d48776b --- /dev/null +++ b/nimbleModel/R/instructions.R @@ -0,0 +1,140 @@ +type2itype <- list( + '0' = 0, + "1_seq" = 1, + "1_mat" = 2, + "1_matp" = 3, + "2_seq_seq" = 4, + "2_seq_mat" = 5, + "2_mat_seq" = 6, + "2_mat_mat" = 7, + "2_seq_matp" = 8, + "2_matp_seq" = 9, + "2_matp_matp" = 10, + "2_mat_matp" = 11, + "2_matp_mat" = 12, + "3_generic" = 13 # Need to deal with itype for _slot cases. +) + +## Stand-alone function for setting up inputs to instrClass constructor. +## This could be embedded in the constructor. +range2instr <- function(range) { + instr <- list() + if(!length(range$indexingRange$indexRanges)) { # No indexing + instr$lens <- 1 + instr$index_types <- 0 + instr$dim <- 0 + } else { + instr$lens <- sapply(range$indexingRange$indexRanges, function(x) x$numElements) + instr$dims <- sapply(range$indexingRange$rangeToIndexSlot, length) + instr$dim <- sum(instr$dims) + instr$slots <- unlist(range$indexingRange$rangeToIndexSlot) + instr$index_types <- sapply(range$indexingRange$indexRanges, function(x) + switch(class(x)[1], + "indexRangeScalarClass" = 2, + "indexRangeSequenceClass" = 1, + "indexRangeMatrixClass" = 2)) + instr$values <- lapply(range$indexingRange$indexRanges, function(x) + switch(class(x)[1], + "indexRangeScalarClass" = x$value, + "indexRangeSequenceClass" = x$start-1, # -1 to avoid constantly adding 1 in calculate() + "indexRangeMatrixClass" = c(t(matrix(x$values, nc = x$numColumns))))) # in calcRange, column major; need row major here for simpler/more efficient determination of indices + } + instr$type <- determineInstrType(instr) + instr$sortID <- range$sortID + instr$declID <- range$declID + return(instr) +} + +## Eventually think about reordering order of looping for efficiency (and take parallelization into account). +## For the moment, we determine mat vs. seq here and then in declClass calculate we will determine whether to +## vectorize based on whether possible based on the declaration. +## Open question of when to determine if to use parallel calculate. +determineInstrType <- function(instr, use_vec = FALSE) { + type <- NULL + if(!length(instr$dims)) + type <- "0" + if(length(instr$dims) == 1) + if(instr$index_types[1] == 1) { + type <- "1_seq" + } else { + if(instr$dims[1] == 1) type <- "1_mat" else type <- "1_matp" + } + if(length(instr$dims) == 2) + if(identical(instr$dims, c(1L,1L))) { + ## Some of these not yet written. + if(identical(instr$index_types, c(1,1))) + type <- "2_vec_vec" + if(identical(instr$index_types, c(1,2))) + if(instr$dims[2] == 1) type <- "2_seq_mat" else type <- "2_seq_matp" + if(identical(instr$index_types, c(2,1))) + if(instr$dims[1] == 1) type <- "2_mat_seq" else type <- "2_matp_seq" + if(identical(instr$index_types, c(2,2))) { + if(all(instr$dims == 1)) type <- "2_mat_mat" + if(all(instr$dims == 2)) type <- "2_matp_matp" + if(instr$dims[[1]] == 2) type <- "2_matp_mat" + if(instr$dims[[2]] == 2) type <- "2_mat_matp" + } + } else type <- "2_generic" + if(length(instr$dims) == 3) type <- "3_generic" + if(is.null(type)) stop("no available specific instruction type") + ## TODO: determine how much about slots will be pre-baked. + if(length(instr$dims) && !identical(instr$slots, 1:instr$dim)) # Non-canonical slot ordering + type <- paste(type, "slots", sep = "_") + return(type2itype[[type]]) +} + +makeInstrList <- function(model, varRanges, use_vec = FALSE) { + if(missing(varRanges)) + varRanges <- model$getVarNames() + ## This works with a char vector of "nodes" or a list of (or single) varRanges + if(is(varRanges, 'varRangeClass')) varRanges <- list(varRanges) + ## First apply calcRule to get overlap between input and the rule. + ## Then make the calcRange to convert to loop indexing. + ## Note that `calcRule$apply` handles converting char to varRange and handling full variable extent. + ranges <- unlist(lapply(varRanges, function(vr) + lapply(model$modelDef$calcRules[[nimbleModel:::getVarName(vr)]]$rules, function(rule) + rule$makeCalcRange(rule$apply(vr)) + ))) + instrList <- nList(instr_nClass)$new() + numRanges <- length(ranges) + instrList$setLength(numRanges) + for(i in 1:numRanges) + instrList[[i]] <- instr_nClass$new(ranges[[i]]) + return(instrList) +} + +instr_nClass <- nClass( + classname = "instr_nClass", + Rpublic = list( + initialize = function(calcRange) { + instrList <- range2instr(calcRange) # This processing could simply be included here in `initialize`. + self$lens <- instrList$lens + self$index_types <- instrList$index_types + self$dim <- instrList$dim + self$dims <- instrList$dims + self$slots <- instrList$slots + self$values <- nList(integerVector)$new() + self$values$setLength(length(self$dims)) + if(self$dim) + for(i in 1:length(self$dims)) + self$values[[i]] <- instrList$values[[i]] + self$type <- instrList$type # Use integer for compilation (would char be ok?). + self$sortID <- instrList$sortID + self$declID <- instrList$declID + }), + Cpublic = list( + lens = 'integerVector', + index_types = 'integerVector', + dim = 'integerScalar', + dims = 'integerVector', + slots = 'integerVector', + values = 'nList(integerVector)', + type = 'integerScalar', + sortID = 'integerVector', + declID = 'integerScalar' + ), compileInfo = list(interface = "full") # TODO: check on this. +) +## TODO: determine how to handle this in terms of it being a predefined nClass +## TODO: see PdV version and determine what `compileInfo` elements are needed. + + diff --git a/nimbleModel/R/model.R b/nimbleModel/R/model.R index 4ad3205..2dc0b64 100644 --- a/nimbleModel/R/model.R +++ b/nimbleModel/R/model.R @@ -42,7 +42,9 @@ modelClass <- R6Class( } } - + origInits <<- inits + origData <<- data + if(length(data) && sum(names(data) == "")) stop("modelClass: 'data' must be a named list") if(any(!sapply(data, function(x) { diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R new file mode 100644 index 0000000..90abf31 --- /dev/null +++ b/nimbleModel/R/modelBaseClass.R @@ -0,0 +1,90 @@ +#' @export +modelBase_nClass <- nClass( + classname = "modelBase_nClass", + Rpublic = list( + ## TODO: bring in methods and fields from nimbleModel:::modelClass. + modelDef = NULL, + dataRules = NULL, + nondataRules = NULL, + predictiveRules = NULL, + nonpredictiveRules = NULL, + getVarNames = function(includeLogProb = FALSE, nodeRanges) { + if(missing(nodeRanges)){ + if(includeLogProb) return(modelDef$varNames) + else return(names(modelDef$varInfo)) + } else { + if(!is.list(nodeRanges)) + nodeRanges <- list(nodeRanges) + return(unique(sapply(nodeRanges, `[[`, 'varName'))) + } + }, + getDependencies = function(nodes, self = TRUE, downstream = FALSE, immediateOnly = FALSE) { + nimbleModel:::getDependencies(modelDef, nodes, self, downstream, immediateOnly) + } + ), + Cpublic = list( + declList = 'nList(declFxnBase_nClass)', + ping = nFunction( + name = "ping", + function() {return(TRUE); returnType(logical())}, + compileInfo = list(virtual=TRUE) + ), + calculate = nFunction( + ## TODO: What is the difference between having this as Cpublic with separate C_fun and having in R_public? + name = "calculate", + function(instrList) { + cat("In uncompiled calculate\n") + if(inherits(instrList, 'instr_nClass')) + instrList <- list(instrList) + if(FALSE) { + ## TODO: self is a Cpub_uncompiled obj, not full specialized model class. + ## So this doesn't work as we need self$modelDef in `makeInstrList()`. + if(!(is.list(instrList) && inherits(instrList[[1]], 'instr_nClass'))) + instrList <- makeInstrList(self, instrList) + } + logProb <- 0 + ord <- order(unlist(lapply(instrList, function(x) x$sortID))) + ## This is where uncompiled stepping through the calcInstrList happens. + for(i in 1:length(ord)) { + ## TODO: need to sort out this lookup process. + ## nodeIdx <- instr$declID + ## nodemember_name <- self$nodeObjNames[nodeIdx] # nodeObjNames is found in the derived class + logProb <- logProb + declList[[instrList[[ord[i]]]$declID]]$calculate(instrList[[ord[i]]]) + } + return(logProb) + }, + returnType = 'numericScalar', + compileInfo = list( + C_fun = function(instrList='nList(instr_nClass)') { + logProb <- 0 + ## For now assuming instructions are in order. + for(i in 1:length(instrList)) { + ## nodemember_name <- self$nodeObjNames[instrList[[i]]$declID] + logProb <- logProb + declList[[instrList[[i]]$declID]]$calculate(instrList[[i]]) + } + return(logProb) + }, + virtual=TRUE + ) + ) + ), + ## See comment above about needing to ensure a virtual destructor + predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("modelBase_nC")), + compileInfo=list(interface="full", + createFromR = FALSE, + Hincludes = c('"declFxnBase_nClass_c_.h"'), #, '"calcInstrList_nClass_c_.h"'), # "declFxnBase_nClass_c_.h" needed for package = TRUE + needed_units = list("declFxnBase_nClass","instr_nClass"), + exportName = "modelBase_nClass_new", + packageNames = c(uncompiled="modelBase_nClass_R", compiled="modelBase_nClass") + ) +) + +# Manually add +# # "#include " to that file, +# after the header content. + + +# nCompile(modelBase_nClass, control=list(generate_predefined=TRUE)) + +## The two "addModelDollarSign" functions are borrowed directly from nimble. +## This should add model$ in front of any names that are not already part of a '$' expression diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R new file mode 100644 index 0000000..0221df6 --- /dev/null +++ b/nimbleModel/R/nimbleModel.R @@ -0,0 +1,511 @@ +## It's unclear what this should return since in nimble one gets a model object +## but with nCompiler, we need a modelClass to compile and then we can create an instance. +## If we create an instance as the output here, one can't then compile that with an algorithm via `nCompile`. +## Need to think more about the workflow for nimble 2.0. +nimbleModel <- function(code, + constants = list(), + data = list(), + inits = list(), + dimensions = list(), + compile = FALSE, + returnClass = TRUE, + where = globalenv(), + debug = FALSE, + check = getNimbleOption('checkModel'), + calculate = TRUE, + name = NULL, + buildDerivs = getNimbleOption('buildModelDerivs'), + userEnv = parent.frame()) { + ## TODO: arg list taken from `nimble`. Revisit which options are needed. + ## For the moment this goes through nimbleModel R6 class and then nCompiler class. Clean that up once ideas are in place. + ## Presumably everything would be in Rpublic initialize for modelBaseClass, so this function will just call modelBase_nClass$new(). + m <- modelClass$new(name = name, code = code, constants = constants, data = data, inits = inits, dimensions = dimensions, userEnv = userEnv) + modelClassInstance <- make_modelClass_from_nimbleModel(m) + if(compile) modelClassInstance <- nCompile(modelClassInstance) + if(returnClass) return(modelClassInstance) # Standard use for when compiling a model(class) and algo(class) together. + model <- modelClassInstance$new() # Otherwise return model object for manipulation from R. +} + +make_modelClass_from_nimbleModel <- function(m, compile=FALSE) { + mDef <- m$modelDef + allVarInfo <- get_varInfo_from_nimbleModel(m) + modelVarInfo <- allVarInfo$vars + declFxnNames <- character() + declInfoList <- list() + declFxnList <- list() + # two vectors for canonical use for calculation instructions + # to move between names and indices of declFxns: + for(i in seq_along(mDef$declInfo)) { + declInfo <- mDef$declInfo[[i]] + decl_methods <- make_decl_methods_from_declInfo(declInfo) + declVars <- decl_methods |> lapply(\(x) all.vars(body(x))) |> unlist() |> unique() |> setdiff(c("idx", "LocalNewLogProb_", "LocalAns_", "model")) %||% character() + declVarInfo <- modelVarInfo[declVars] + SLN <- declInfo$sourceLineNumber + decl_classname <- paste0("declClass_", SLN) # name of an nClass generator + decl_RvarName <- paste0("declFxn_", SLN) # name of an R variable holding the nClass generator + decl_membername <- paste0("decl_", SLN) # name of model member variable holding an instance of the nClass + # Currently, we can't just make a list of these but need them as named objects in the environment + declFxnList[[decl_RvarName]] <- make_declFxn_nClass(declVarInfo, decl_methods, decl_classname) + assign(decl_RvarName, + declFxnList[[decl_RvarName]] + ) + declInfoList[[i]] <- make_decl_info_for_model_nClass(decl_membername, decl_RvarName, decl_classname, declVarInfo) + } + modelClassInstance <- makeModel_nClass(modelVarInfo, declInfoList, inits = m$origInits, data = m$origData, model = m, classname = "my_model", env = environment()) +} + + +nm_addModelDollarSign <- function(expr, exceptionNames = character(0)) { + if(is.numeric(expr)) return(expr) + if(is(expr, 'srcref')) return(expr) + if(is.name(expr)) { + if((as.character(expr) %in% exceptionNames) || (as.character(expr) == '')) return(expr) + proto <- quote(model$a) + proto[[3]] <- expr + return(proto) + } + if(is.call(expr)) { + if(expr[[1]] == '$'){ + expr[2] <- lapply(expr[2], function(listElement) nm_addModelDollarSign(listElement, exceptionNames)) + return(expr) + } + if(expr[[1]] == 'returnType') + return(expr) + if(length(expr) > 1) { + expr[2:length(expr)] <- lapply(expr[-1], function(listElement) nm_addModelDollarSign(listElement, exceptionNames)) + return(expr) + } + } + return(expr) +} + +# Turn variables and methods into a declFxn nClass +make_declFxn_nClass <- function(varInfo = list(), + methods = list(), + classname) { + # varInfo will be a list (names not used) of name, nDim, sizes. + # These are the model member variables to be used by the declFxn. + # They will be used in a constructor to set up C++ references to model variables. + CpublicVars <- varInfo |> lapply(\(x) paste0("ref(double(", x$nDim ,", interface=FALSE))")) + names(CpublicVars) <- varInfo |> lapply(\(x) x$name) |> unlist() + + +# varInfo_2_symbol <- \(x) nCompiler:::symbolBasic$new( +# type="double", nDim=x$nDim, name="", isRef=TRUE, isConst=FALSE, interface=FALSE) # In future maybe isConst=TRUE, but it might not matter much +# symbolList <- varInfo |> lapply(varInfo_2_symbol) +# names(symbolList) <- varInfo |> lapply(\(x) x$name) |> unlist() + numVars <- length(varInfo) + +# CpublicVars <- names(symbolList) |> lapply(\(x) eval(substitute(quote(T(symbolList$NAME)), +# list(NAME=as.name(x))))) +# names(CpublicVars) <- names(symbolList) + # This is a kluge to have a model field in the Cpublic_obj, + # needed for uncompiled purposes, and for compiled purposes + # we instead use references to model variables. So + # the declared type here is arbitrary. + initFun <- function(){} + + if(numVars > 0) { + # ctorArgNames <- paste0(names(symbolList), '_') + ctorArgNames <- paste0(names(CpublicVars), '_') + # List used when generating C++ constructor code to allow direct initializers, necessary for references. + # initializersList <- paste0(names(symbolList), '(', ctorArgNames ,')') + initializersList <- paste0(names(CpublicVars), '(', ctorArgNames ,')') + formals(initFun) <- structure(as.pairlist(CpublicVars), names = ctorArgNames) + } else { + initializersList <- character() + } + if(missing(classname)) + classname <- declFxnLabelCreator() + + baseclass <- paste0("declFxnClass_<", classname, ">") + + # Rpublic method to set the model pointer/reference. + setModel <- function(model) { + if(!isCompiled()) { + self$model <- model + #private$Cpublic_obj$model <- model + } + else + warning("setModel called on compiled object; no action taken") + } + +# This was a prototype + declFxn_nClass <- substitute( + nClass( + inherit = declFxnBase_nClass, + classname = CLASSNAME, + Rpublic = RPUBLIC, + Cpublic = CPUBLIC, + compileInfo = list( + createFromR = FALSE, # Without a default constructor (which we've disabled here), createFromR is impossible + nClass_inherit = list(base = BASECLASS)) # Ideally this line would be obtained from a base nClass, but we insert it directly for now + ), + list( + CPUBLIC = c( + list( + nFunction( + initFun, + compileInfo = list(constructor=TRUE, initializers = initializersList) + ) + ) |> structure(names = classname), + CpublicVars, + list(model = "RcppList"), + methods + ), + RPUBLIC = list(#model = NULL, + setModel = setModel), + CLASSNAME = classname, + BASECLASS = baseclass + )) + eval(declFxn_nClass) +} +#test <- nCompiler:::type2symbol('CppVar(baseType = type2cpp("numericVector"), ref=TRUE, const=TRUE)') + +# Make all the info needed to include a decl in a model class. +# The declFxn_nClass should be created first. +# Currently it needs to have a name to include in nCompile(). Later we might be able to pass the object itself +# At first drafting this is fairly trivial but could grow in complexity. + +make_decl_info_for_model_nClass <- function(membername, + declFxnName, + classname, + varInfo = list() + ) { + ctorArgs <- varInfo |> lapply(\(x) x$name) |> unlist() + + list(declFxnName = declFxnName, + membername = membername, + classname = classname, + ctorArgs = ctorArgs) +} + +makeModel_nClass <- function(varInfo, + decls = list(), + classname, + sizes = list(), + inits = list(), + data = list(), + model = NULL, + env = parent.frame() + ) { + # varInfo will be a list (names not used) of name, nDim, sizes. + CpublicModelVars <- varInfo |> lapply(\(x) paste0("numericArray(nDim=",x$nDim,")")) + names(CpublicModelVars) <- varInfo |> lapply(\(x) x$name) |> unlist() + opDefs <- list( + base_ping = nCompiler:::getOperatorDef("custom_call"), + setup_decl_mgmt = nCompiler:::getOperatorDef("custom_call"), + do_setup_decl_mgmt_from_names = nCompiler:::getOperatorDef("custom_call") + ) + opDefs$base_ping$returnType <- nCompiler:::type2symbol(quote(void())) # How can this be passed into nClass? + opDefs$base_ping$labelAbstractTypes$recurse <- FALSE + opDefs$setup_decl_mgmt$returnType <- nCompiler:::type2symbol(quote(void())) + opDefs$setup_decl_mgmt$labelAbstractTypes$recurse <- FALSE + opDefs$do_setup_decl_mgmt_from_names$returnType <- nCompiler:::type2symbol(quote(void())) + opDefs$do_setup_decl_mgmt_from_names$labelAbstractTypes$recurse <- FALSE + + if(missing(classname)) + classname <- modelLabelCreator() + + CpublicMethods <- list( + do_setup_decl_mgmt = nFunction( + name = "call_setup_decl_mgmt", + function() {}, + compileInfo=list( + C_fun = function() {setup_decl_mgmt()}) + ), + setup_decl_mgmt_from_names = nFunction( + name = "call_setup_decl_mgmt_from_names", + function(declNames) {}, + compileInfo=list( + C_fun = function(declNames="RcppCharacterVector") {do_setup_decl_mgmt_from_names(declNames)}) + ), + print_decls = nFunction( + name = "print_decls", + function() {}, + compileInfo=list( + C_fun = function() {cppLiteral('modelClass_::c_print_decls();')}) + ), + set_from_list = nFunction( + name = "set_from_list", + function(Rlist) {for(v in names(Rlist)) + if(exists(v, self, inherits=FALSE)) self[[v]] <- Rlist[[v]]}, + compileInfo=list( + C_fun=function(Rlist = 'RcppList') {cppLiteral('modelClass_::set_from_list(Rlist);')}) + ), + resize_from_list = nFunction( + name = "resize_from_list", + function(Rlist) {for(v in names(Rlist)) + if(exists(v, self, inherits=FALSE)) self[[v]] <- nArray(dim=Rlist[[v]])}, + compileInfo = list( + C_fun=function(Rlist = 'RcppList') {cppLiteral('modelClass_::resize_from_list(Rlist);')}) + ) + ) + # decls will be a list of membername, declFxnName, (decl) classname, ctorArgs (list) + decl_pieces <- decls |> lapply(\(x) { + #nClass_type <- paste0(x$declFxnName, "()") + init_string <- paste0('nCpp("', x$membername, '( new ', x$classname, '(', + paste0(x$ctorArgs, collapse=","), '))")') + list(nClass_type = x$declFxnName, + init_string = init_string, + membername = x$membername) + }) + declObjNames <- (decl_pieces |> lapply(\(x) x$membername) |> unlist()) %||% character() + # declObjNames also serves for canonical lookup of names by index. + # e.g. declObjNames[i] gives the member name of the index=i decl member. + declObjName_2_declIndex <- seq_along(declObjNames) |> structure(names=declObjNames) + # Inversely, declobjName_2_declIndex["decl_3"] gives the index of that decl. + CpublicDeclFuns <- decl_pieces |> lapply(\(x) x$nClass_type) |> setNames(declObjNames) + # CpublicDeclFuns <- list( + # beta_decl = 'decl_dnorm()' + # ) + CpublicCtor <- list( + nFunction( + function(){}, + compileInfo = list(constructor=TRUE, + #initializers = c('nCpp("beta_decl(new decl_dnorm(mu, beta, 1))")')) + initializers = decl_pieces |> lapply(\(x) x$init_string) |> unlist()) + ) + ) |> structure(names = classname) + initialize <- function(sizes = list(), inits = list(), data = list()) { + # It is not very easy to set debug onto the initialize function, so + # here is a magic flag. + if(isTRUE(.GlobalEnv$.debugModelInit)) browser() + super$initialize() + if(isCompiled()) + self$setup_decl_mgmt_from_names(self$declObjNames) + if(!isCompiled()) { + for(declObj in self$declObjNames) { + self[[declObj]] <- eval(as.name(self$CpublicDeclFuns[[declObj]]))$new() + self[[declObj]]$setModel(self) + } + } + + # First expand any provided or default sizes + # To-Do possibly merge the argument sizes and defaultSizes by element. + if(missing(sizes)) sizes <- self$defaultSizes + if(length(sizes)) resize_from_list(sizes) + + # Then any provided inits over-ride any provided sizes + # To-Do: Ditto + if(missing(inits)) inits <- self$defaultInits + if(length(inits)) set_from_list(inits) + + # TODO: do we want to handle data differently? + # TODO: need to work through not setting as 'data' if values are NA; + # check back against how dataRules work in nimbleModel work. + if(missing(data)) data <- self$defaultData + if(length(data)) set_from_list(data) +browser() + + + } + baseclass <- paste0("modelClass_<", classname, ">") + # CpublicDeclFuns has elements like "decl_1 = quote(declFxn_1())" + # We provide it in Cpublic to declare C++ member variables with types. + # We also place the list itself in the class so that we can look up for uncompiled execution + # the objects that need to be created in initialize. + # If we someday make type declarations and initializations more automatic, we can avoid this duplication. + ans <- substitute( + nClass( + classname = CLASSNAME, + inherit = modelBase_nClass, + compileInfo = list(opDefs = OPDEFS, + nClass_inherit = list(base=BASECLASS)#, +# needed_units = list("declFxnBase_nClass"), # needed for package=TRUE +# Hincludes = '"declFxnBase_nClass_c_.h"' # needed for package=TRUE + ), + Rpublic = RPUBLIC, + Cpublic = CPUBLIC, + env = env + ), + list(OPDEFS = opDefs, + # A list of individual elements + RPUBLIC = list(initialize=initialize, + declObjNames = declObjNames, + declObjName_2_declIndex = declObjName_2_declIndex, + defaultSizes = sizes, + defaultInits = inits, + defaultData = data, + modelDef = model$modelDef, + ## TODO: add other fields from `nimbleModel::modelClass` such as dataRules, predictiveRules, etc. + CpublicDeclFuns = CpublicDeclFuns), + # A concatenation of lists + CPUBLIC = c(CpublicDeclFuns, CpublicModelVars, CpublicCtor, CpublicMethods), + CLASSNAME = classname, + BASECLASS = baseclass) + ) + eval(ans) +} + +## Get varInfo from new nimbleModel +get_varInfo_from_nimbleModel <- function(model) { + mDef <- model$modelDef + extract <- \(x) x |> lapply(\(x) list(name = x$varName, nDim = x$nDim)) + vars <- mDef$varInfo |> extract() + logProbVars <- mDef$logProbVarInfo |> extract() + # The resize_from_list method will error out if a scalar is included. + # The maxs is empty for scalars, so they are automatically omitted from the sizes result here. + extract_sizes <- \(x) x|> lapply(\(x) x$maxs) + sizes <- mDef$varInfo |> extract_sizes() + logProb_sizes <- mDef$logProbVarInfo |> extract_sizes() + list( + vars = c(vars, logProbVars), + sizes = c(sizes, logProb_sizes) + ) +} + +# make_stoch_calculate <- function(LHSrep, RHSrep, logProbExprRep) { +# lenRHS <- length(RHSrep) +# if(length(RHS) > 1) { +# RHSrep[3:(lenRHS+1)] <- RHSrep[2:lenRHS] +# names(RHSrep)[3:(lenRHS+1)] <- names(RHSrep)[2:lenRHS] +# } +# RHSrep[[2]] <- LHSrep +# names(RHSrep)[2] <- "" +# RHSrep[[lenRHS+2]] <- 1 +# names(RHSrep)[lenRHS+2] <- "log" +# # We create separate code for R and C execution. +# calc1Cfun <- substitute( +# function(idx) {LHS <- RHS; return(LHS)}, +# list(LHS = logProbExprRep, RHS = RHSrep) +# ) |> eval() +# make_calculate_from_Cfun(calc1Cfun) +# } + +make_stoch_sim_line <- function(LHSrep, RHSrep) { + BUGSdistName <- nCompiler:::safeDeparse(RHSrep[[1]]) + distInfo <- getDistributionInfo(BUGSdistName) + sim_code <- as.name(distInfo$simulateName) + if(is.null(sim_code)) stop("Could not find simulation ('r') function for ", BUGSdistName) + RHSrep[[1]] <- sim_code + # scoot all named arguments right 1 position + if(length(RHSrep) > 1) { + for(i in (length(RHSrep)+1):3) { + RHSrep[i] <- RHSrep[i-1] + names(RHSrep)[i] <- names(RHSrep)[i-1] + } + } + RHSrep[[2]] <- 1 + names(RHSrep)[2] <- '' + sim_line <- substitute( + LHS <- RHS, + list(LHS = LHSrep, RHS = RHSrep)) + sim_line +} + +make_stoch_calc_line <- function(LHSrep, RHSrep, logProbExprRep, diff = FALSE) { + lenRHS <- length(RHSrep) + if(length(RHSrep) > 1) { + RHSrep[3:(lenRHS+1)] <- RHSrep[2:lenRHS] + names(RHSrep)[3:(lenRHS+1)] <- names(RHSrep)[2:lenRHS] + } + RHSrep[[2]] <- LHSrep + names(RHSrep)[2] <- "" + RHSrep[[lenRHS+2]] <- 1 + names(RHSrep)[lenRHS+2] <- "log" + # We create separate code for R and C execution. + if(!diff) { + calc_line <- substitute( + LHS <- RHS, + list(LHS = logProbExprRep, RHS = RHSrep)) + } else { + calc_line <- substitute( + LocalNewLogProb_ <- RHS, + list(RHS = RHSrep)) + } + calc_line +} + +make_determ_calc_line <- function(LHSrep, RHSrep) { + calc_line <- substitute( + LHS <- RHS, + list(LHS = LHSrep, RHS = RHSrep)) + calc_line +} + +make_nFxn_from_Cfun <- function(Cfun) { + Rfun <- Cfun + body(calc1Rfun) <- nm_addModelDollarSign(body(Cfun), exceptionNames = c("idx")) + nFxn <- nFunction( + name = "calc_one", + fun = Rfun, + compileInfo=list(C_fun=Cfun), + argTypes = list(idx = 'integerVector'), + returnType = 'numericScalar') + #declVars <- all.vars(body(calc1Cfun)) |> setdiff("idx") + nFxn +} + +make_decl_method_nFxn <- function(f, name, returnType='numericScalar') { + Cfun <- f + Rfun <- f + body(Rfun) <- nm_addModelDollarSign(body(f), exceptionNames = c("idx", "LocalNewLogProb_", "LocalAns_")) + if(is.null(returnType)) returnType <- 'void' + nFxn <- nFunction( + name = name, + fun = Rfun, + argTypes = list(idx = 'integerVector'), + returnType = returnType, + compileInfo=list(C_fun=Cfun), + ) + nFxn +} + +make_decl_methods_from_declInfo <- function(declInfo) { + # pieces are adapted from Chris' code in nimbleModel and/or old nimble. + # + # This function creates a calc_one nFunction that calculates single index case. + # This will then be used by generic iterator over indices. + # Vectorized cases can be added in this basic framework later. + modelCode <- declInfo$calculateCode + LHS <- modelCode[[2]] + RHS <- modelCode[[3]] + type <- if(modelCode[[1]]=="~") "stoch" else "determ" # or use declInfo$stoch (logical) + context <- declInfo$declRule$context + replacements <- sapply(seq_along(context$singleContexts), + function(i) parse(text = paste0('idx[',i,']'))[[1]]) + names(replacements) <- context$indexVarNames + LHSrep <- eval(substitute(substitute(e, replacements), list(e = LHS))) + RHSrep <- eval(substitute(substitute(e, replacements), list(e = RHS))) + + if(type == 'determ') { + methodList <- eval(substitute( + list( + sim_one = (function(idx) {calc_one(idx)}) |> + make_decl_method_nFxn("sim_one", NULL), + calc_one = (function(idx) {DETERMCALC; return(invisible(0))}) |> + make_decl_method_nFxn("calc_one"), + calcDiff_one = (function(idx) {calc_one(idx);return(invisible(0))}) |> + make_decl_method_nFxn("calcDiff_one"), + getLogProb_one = (function(idx) {return(0)}) |> + make_decl_method_nFxn("getLogProb_one") + ), + list(DETERMCALC = make_determ_calc_line(LHSrep, RHSrep)) + )) + } + if(type == 'stoch') { + logProbExpr <- declInfo$genLogProbExpr() + logProbExprRep <- eval(substitute(substitute(e, replacements), list(e = logProbExpr))) + methodList <- eval(substitute( + list( + sim_one = (function(idx) { STOCHSIM }) |> + make_decl_method_nFxn("sim_one", NULL), + calc_one = (function(idx) { STOCHCALC; return(invisible(LOGPROB)) }) |> + make_decl_method_nFxn("calc_one"), + calcDiff_one = (function(idx) {STOCHCALC_DIFF; LocalAns_ <- LocalNewLogProb_ - LOGPROB; + LOGPROB <- LocalNewLogProb_; return(invisible(LocalAns_))}) |> + make_decl_method_nFxn("calcDiff_one"), + getLogProb_one = (function(idx) { return(LOGPROB) }) |> + make_decl_method_nFxn("getLogProb_one") + ), + list( LOGPROB = logProbExprRep, + STOCHSIM = make_stoch_sim_line(LHSrep, RHSrep), + STOCHCALC = make_stoch_calc_line(LHSrep, RHSrep, logProbExprRep), + STOCHCALC_DIFF = make_stoch_calc_line(LHSrep, RHSrep, logProbExprRep, diff=TRUE)) + )) + } + methodList +} + + diff --git a/nimbleModel/R/nodeRules.R b/nimbleModel/R/nodeRules.R index c062875..42652e3 100644 --- a/nimbleModel/R/nodeRules.R +++ b/nimbleModel/R/nodeRules.R @@ -127,6 +127,7 @@ declRuleClass <- R6Class( originalIndexingRule = NULL, # Determines original indexing (based on context). decl = NULL, # Full declInfo; nodeRuleClass$expr is just LHS. calculate = NULL, # Generic function for calculation. + ID = NULL, # Unique ID that will be the index of the declClass in C++ (TBD how this is baked in). ## TODO: remove this: test = rep(0, 10), ## test element used for testing calculation while modelDef doesn't have acccess to a model test2 = matrix(0, 3, 5), @@ -239,7 +240,7 @@ calcRuleClass <- R6Class( indexingRange <- declRule$originalIndexingRule$apply(inputRange) if(is.null(indexingRange)) return(NULL) - result <- calcRangeClass$new(varName, indexingRange, declRule$calculate, sortID, multiSortIDindex) + result <- calcRangeClass$new(varName, indexingRange, declRule$ID, sortID, multiSortIDindex) return(result) }, @@ -395,75 +396,15 @@ calcRangeClass <- R6Class( sortID = NULL, calcFun = NULL, multiSortIDindex = NULL, - initialize = function(varName, indexingRange, calcFun, sortID, multiSortIDindex) { + declID = NULL, + initialize = function(varName, indexingRange, declID, sortID, multiSortIDindex) { varName <<- varName indexingRange <<- indexingRange calcFun <<- calcFun ## note that calcFun itself is not vectorized sortID <<- sortID + declID <<- declID multiSortIDindex <<- multiSortIDindex - }, - - ## Generic calculate function that crosses the indexRanges in the indexingRange (a varRange) - ## and extracts the original indices to feed into calculate nodeFunction - ## that operates on set of scalar indices. - - ## Keep indexing internal to the indexRange to avoid complicated and possibly repetitive - ## calculation of internal indexing. - - ## Will need to figure out how this is going to get compiled. - ## This will rely on nCompiler indexing of eigen tensors for static block indexes, e.g. '3:5' in x[i, 3:5] - ## which will presumably use the information in the symbolicParentNodes. - - calculate = function() { - numRanges <- length(indexingRange$indexRanges) - if(!numRanges) { # no indexing - result <- calcFun(NULL) - } else { - indexRange_lengths <- sapply(indexingRange$indexRanges, - function(x) x$numElements) - indexPositions <- indexingRange$rangeToIndexSlot - len <- prod(indexRange_lengths) - - ## TODO: This is a placeholder so we can test numerical results - ## once fuller workflow is in place, remove this and assignment of output of calcFun() - result <- rep(0, len) - - ## Set up information so `getNext` repeats index values for outer loop indices. - delay <- 1 - for(irIndex in rev(seq_len(numRanges))) { # work from inner-most loop outwards - indexingRange$indexRanges[[irIndex]]$setDelay(delay) - delay <- delay * indexingRange$indexRanges[[irIndex]]$numElements - } - - if(length(sortID) == 1 || len == 1) { - index <- numeric(length(indexingRange$indexSlotToRange)) ## vector to hold the original index values - for(item in seq_len(len)) { - for(irIndex in seq_len(numRanges)) - index[indexPositions[[irIndex]]] <- indexingRange$indexRanges[[irIndex]]$getNext() - result[item] <- calcFun(index) ## scalar calculation - } - } else { - index <- matrix(0, len, length(indexingRange$indexSlotToRange)) ## vector to hold the original index values - sortIDvals <- rep(0, len) - for(item in seq_len(len)) { - for(irIndex in seq_len(numRanges)) { - index[item, indexPositions[[irIndex]]] <- indexingRange$indexRanges[[irIndex]]$getNext() - } - sortIDvals[item] <- sortID[index[item, multiSortIDindex]] - } - for(item in order(sortIDvals)) - result[item] <- calcFun(index[item, ]) - } - } - ## Note that result will be vectorized based on the loop ordering so in simple rectangular - ## settings such as `y[i,j]` with `i` the outer index, it will be row-major. - return(result) - } - - ## simulate() should be very similar to calculate() - ## need to think more about getParam, getBound, etc., but probably also very similar, - ## just swapping out calcFun() for appropriate function. ) ) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R new file mode 100644 index 0000000..d6906c2 --- /dev/null +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -0,0 +1,279 @@ +# Test code needed for new nimbleModel system. + +library(nimbleModel) +library(testthat) + +## TODO: will location and access to predefined nClasses be as described below given they will live +## in `nimbleModel` package? How will dependence on nCompiler work? + +## TODO: before I generate the predefined code, need to check on what needs to be done in terms of +## compileInfo for modelBaseClass and declFxnBaseClass. + +## # To update the set of predefined nClasses +## # generate new predef/instr_nC. Move that directly to package code inst/nimbleModel/predef/nodeInstr_nC +## nCompile(instr_nClass, control=list(generate_predefined=TRUE)) +## test <- nCompile(instr_nClass) +## # +## # generate new predef/nodeFxnBase_nC. Move to package and add +## # "#include " in the hContent +## # after declaration of newFxnBase_nClass +## nCompile(nodeFxnBase_nClass, control=list(generate_predefined=TRUE)) +## test <- nCompile(nodeFxnBase_nClass) +## # +## # generate new predef/modelBase_nC. Move to package and add +## # "#include " to that file, +## # after the declaration of modelBase_nClass. +## nCompile(modelBase_nClass, control=list(generate_predefined=TRUE)) +## test <- nCompile(modelBase_nClass) +## #nCompile(nodeFxnBase_nClass, nodeInstr_nClass, control=list(generate_predefined=TRUE)) +## #nCompile(nodeInstr_nClass, calcInstr_nClass, modelBase_nClass, nodeFxnBase_nClass, calcInstrList_nClass, control=list(generate_predefined=TRUE)) + +## TODO: revise these tests for instrClass (flattened approach) + +test_that("nimble model prototype works", { + nodeVarInfo <- list(list(name = "x", nDim = 1), list(name = "mu", nDim = 1), + list(name = "sd", nDim = 0)) + calc_one <- nFunction( + name = "calc_one", + fun = function(inds) { + ans <- model$x[inds[1]] + return(ans) + }, + compileInfo = list( + C_fun = function(inds = 'integerVector') { + returnType('numericScalar') + ans <- x[inds[1]] + return(ans) + } + ) + ) + my_nodeFxn <- make_node_nClass(nodeVarInfo, list(calc_one=calc_one), "test_node") + my_nodeInfo <- make_node_info_for_model_nClass("beta_NF1", "my_nodeFxn", "test_node", nodeVarInfo) + + modelVarInfo <- list(list(name="x", nDim = 1), + list(name = "mu", nDim = 1), + list(name = "sd", nDim = 0), + list(name = "gamma", nDim = 2)) + #debug(makeModel_nClass) + ncm1 <- makeModel_nClass(modelVarInfo, list(my_nodeInfo), classname = "my_model", env=environment()) + #undebug(addGenericInterface_impl) + #undebug(nCompile_finish_nonpackage) + for(package in c(FALSE, TRUE)) { + Cncm1 <- nCompile(ncm1, returnList=TRUE, package=package) + #Cncm1 <- nCompile(modelBase_nClass, nodeFxnBase_nClass, calcInstrList_nClass, calcInstr_nClass, nodeInstr_nClass, ncm1, my_nodeFxn) + for(mode in c("uncompiled", "compiled")) { + if(mode=="compiled") { + obj <- Cncm1$ncm1$new() + } else { + obj <- ncm1$new() + } + # obj$do_setup_node_mgmt() + nodeObj <- obj$beta_NF1 + obj$x <- 1:3 + expect_equal(obj$x, 1:3) + + obj$set_from_list(list(x = 10:11)) + # expect Problem msg: (alpha is not a field in the class) + obj$set_from_list(list(mu = 110, x = 11:20, alpha = 101)) + obj$mu + + obj$resize_from_list(list(x = 7)) + # expect Problem msg: + obj$resize_from_list(list(alpha = 5, mu = 3, gamma = c(2, 4))) + expect_equal(length(obj$mu), 3) + expect_equal(dim(obj$gamma), c(2, 4)) + obj$resize_from_list(list(x = 5, gamma = c(3, 5))) + expect_equal(length(obj$x), 5) + expect_equal(dim(obj$gamma), c(3, 5)) + + obj$x <- 11:15 + expect_equal(nodeObj$calc_one(c(3)), 13) + rm(obj, nodeObj); gc() + } + } +}) + +test_that("nodeInstr_nClass and calcInstr_nClass basics work", { + for(package in c(FALSE, TRUE)) { + test <- nCompile(nodeInstr_nClass, calcInstr_nClass, calcInstrList_nClass, control=list(generate_predefined=FALSE), package = package) + calcInstrList <- test$nList_calcInstr_nClass$new() + calcInstr <- test$calcInstr_nClass$new() + expect_equal(calcInstr$nodeInstrVec, NULL) + ni1 <- test$nodeInstr_nClass$new() + ni2 <- test$nodeInstr_nClass$new() + ni1$methodInstr <- 1 + ni2$methodInstr <- 2 +# nList("integerVector")$new() +# ni1$indsInstrVec <- nList("integerVector")$new() + ni1$indsInstrVec[1:2] <- list(1:2, 3:4) + ni2$indsInstrVec + ni2$indsInstrVec[1:2] <- list(11:12, 13:14) + calcInstr$nodeInstrVec + calcInstr$nodeInstrVec[1:2] <- list(ni1, ni2) + + expect_true(length(calcInstr$nodeInstrVec)==2) + expect_identical(calcInstr$nodeInstrVec[[1]]$indsInstrVec |> as.list(), list(1:2, 3:4)) + expect_identical(calcInstr$nodeInstrVec[[2]]$indsInstrVec |> as.list(), list(11:12, 13:14)) + calcInstrList[1] <- list(calcInstr) + expect_equal(calcInstrList |> as.list(), list(calcInstr)) + rm(calcInstrList, calcInstr, ni1, ni2); gc() + } +}) + +###### + +## This is somewhat redundant with the first test +test_that("nimble model variables are set up", { + library(nimbleModel) + code <- quote({ + sd ~ dunif(0, 10) + for(i in 1:5) { + y[i] ~ dnorm(x[i+1], sd = sd) + } + }) + m <- modelClass$new(code) + varInfo <- get_varInfo_from_nimbleModel(m) + modelVars <- varInfo$vars + # Try making a model with no nodeFxns + ncm1 <- makeModel_nClass(modelVars, list(), classname = "my_model", env = environment()) + Cncm1 <- nCompile(ncm1, returnList=TRUE) + #Cncm1 <- nCompile(modelBase_nClass, nodeFxnBase_nClass, calcInstrList_nClass, calcInstr_nClass, nodeInstr_nClass, ncm1) + obj <- Cncm1$ncm1$new() + obj$resize_from_list(varInfo$sizes) + expect_equal(length(obj$x), 6) + expect_equal(length(obj$y), 5) + expect_equal(length(obj$logProb_y), 5) +}) + +######## +# nOptions(pause_after_writing_files=TRUE) +# Try automating the whole model creation including nodeFxns +# Ditto: this works but relies on nimbleModel +test_that("nimble model with stochastic and deterministic nodes is created and compiles", { + library(nimbleModel) + code <- quote({ + sd ~ dunif(0, 10) + for(i in 1:5) { + z[i] <- x[i+1] + 10 + y[i] ~ dnorm(x[i+1], sd = sd) + } + }) + m <- modelClass$new(code) + + ## Check that a separate R implementation was created + mDef_ <- m$modelDef + dI <- mDef_$declInfo[[2]] + nFxn <- make_node_methods_from_declInfo(dI) + expect_true(!is.null(NFinternals(nFxn[[1]])$R_fun)) + dI <- mDef_$declInfo[[3]] + nFxn <- make_node_methods_from_declInfo(dI) + expect_true(!is.null(NFinternals(nFxn[[1]])$R_fun)) + + for(mode in c("uncompiled", "compiled")) { + package_options <- if(mode=="compiled") c(FALSE, TRUE) else TRUE + for(package in package_options) { + nMod <- make_model_from_nimbleModel(m, compile=FALSE) + if(mode=="compiled") { + expect_no_error(CnMod <- nCompile(nMod, package = package)) + nMod <- CnMod + } + expect_no_error(obj <- nMod$new()) + obj$y <- 1:5 + expect_equal(obj$y, 1:5) + vals <- list(x = 2:7, y = 11:15, sd = 8) + obj$set_from_list(vals) + expect_equal(obj$x, vals$x) + rm(obj); gc() + } + } +}) + +message("test-nimbleModel does not have tests of calculate etc.") + +if(FALSE) { + nodeFxn_2_nodeIndex <- c(nodeFxn_1 = 1, nodeFxn_3 = 2) + + calcInputList <- list(list(nodeFxn="nodeFxn_1", # which declaration (nodeFxn) + nodeInputVec = list(list(methodInput=1, # which index iteration method + indsInputVec=list(1))))) # input(s) to index iterations + + calcInstrList <- calcInputList_to_calcInstrList(calcInputList, test) + + obj$calculate(calcInstrList) +} +######## + + +## CJP experimentation with nimbleModel, modelClass stuff. +library(nimbleModel);library(nCompiler) + +# source('modelBaseClass.R') +# source('declFxnBaseClass.R') +# source('nimbleModel.R') +# source('instructions.R') + +code <- quote({ + sd ~ dunif(0, 10) + for(i in 1:5) { + z[i] <- x[i+1] + 10 + y[i] ~ dnorm(x[i+1], sd = sd) + } +}) +inits <- list(sd = 1.5) +data <- list(y = rnorm(5)) +nm <- modelClass$new(code, inits = inits, data = data) +mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) +m <- mclass$new(inits=list(sd=5)) + +## m$calculate('sd') # Doesn't work because Cpublic calculate can't run makeInstrList as it can't access modelDef. + +instrList <- nimbleModel:::makeInstrList(m, 'sd') +m$calculate(instrList) +instrList <- nimbleModel:::makeInstrList(m, 'y') +m$calculate(instrList) + +# cr <- m$modelDef$calcRules[['y']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['y']]$rules[[1]]$apply('y')) +# cr <- m$modelDef$calcRules[['sd']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['sd']]$rules[[1]]$apply('sd')) + +## Direct access to decl calculation works. +out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calc_one(0) +out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calc_0(instrList[[1]]) +out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calculate(instrList[[1]]) + +# how initialize a list of declFxns? + +# How get nCompiler to know about base class not in nCompiler? +# tmp=nList(nimbleModel:::declFxnBase_nClass) +#Error in self$resolveSym(project_env, ...) : +# In resolveSym method for symbolTBD (, :::), could not resolve an nClass generator. + +## experimenting ((not working) with creating and populating nLists +rNL <- nList(numericVector) +cl <- nClass( + Cpublic =list( + x = 'rNL', + myfun = nFunction( + function(y = 'numericScalar') { + return(y*x[[2]]) + }, returnType = 'numericVector' + ), + pop = nFunction( + function(x1 = 'numericVector', x2='numericVector') { + length(x) <- 3 + + x[[1]] <- x1 # this is still `1` as index in C++ + x[[2]] <- x2 + }) + )) +ccl <- nCompile(cl, rNL=rNL) +obj <- ccl[[1]]$new() +obj$pop(rnorm(3),rnorm(5)) +obj$myfun(3) + + +## full workflow with getDeps + +## work on sortID + + + From b6e9a4d3372234487f76a72f30aabc1f69cf5a16 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 09:02:48 -0700 Subject: [PATCH 02/32] Get uncompiled calculate prototype fully working. --- nimbleModel/DESCRIPTION | 2 +- nimbleModel/NAMESPACE | 3 + ...{declFxnBaseClass.R => declFunBaseClass.R} | 16 +- nimbleModel/R/instructions.R | 15 +- nimbleModel/R/modelBaseClass.R | 62 ++++--- nimbleModel/R/modelDecl.R | 2 +- nimbleModel/R/modelDef.R | 10 ++ nimbleModel/R/nimbleModel.R | 159 ++++++++++-------- nimbleModel/R/nodeRules.R | 7 +- nimbleModel/tests/testthat/test-nimbleModel.R | 35 ++-- 10 files changed, 170 insertions(+), 141 deletions(-) rename nimbleModel/R/{declFxnBaseClass.R => declFunBaseClass.R} (84%) diff --git a/nimbleModel/DESCRIPTION b/nimbleModel/DESCRIPTION index 693a2ba..770b628 100644 --- a/nimbleModel/DESCRIPTION +++ b/nimbleModel/DESCRIPTION @@ -43,7 +43,7 @@ Collate: varRange.R varRules.R varStore.R - declFxnBaseClass.R + declFunBaseClass.R modelBaseClass.R instructions.R nimbleModel.R diff --git a/nimbleModel/NAMESPACE b/nimbleModel/NAMESPACE index 57a7f59..a7cc763 100644 --- a/nimbleModel/NAMESPACE +++ b/nimbleModel/NAMESPACE @@ -69,3 +69,6 @@ export(messageIfVerbose) export(calc_dmnormAltParams) export(calc_dwishAltParams) + +export(nimbleModel) +export(makeInstrList) diff --git a/nimbleModel/R/declFxnBaseClass.R b/nimbleModel/R/declFunBaseClass.R similarity index 84% rename from nimbleModel/R/declFxnBaseClass.R rename to nimbleModel/R/declFunBaseClass.R index d35aa9c..1f66749 100644 --- a/nimbleModel/R/declFxnBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -1,6 +1,6 @@ #' @export -declFxnBase_nClass <- nClass( - classname = "declFxnBase_nClass", +declFunBase_nClass <- nClass( + classname = "declFunBase_nClass", Cpublic = list( ## model = 'modelBase_nClass', ping = nFunction( @@ -20,11 +20,11 @@ declFxnBase_nClass <- nClass( }, returnType = 'numericScalar', compileInfo = list(virtual=TRUE) ), - ## TODO: for all these type-specific calculates, how do we call the methods of the declFxn_nClass object? + ## TODO: for all these type-specific calculates, how do we call the methods of the decl_nClass object? calc_0 = nFunction( name = 'calc_0', function(instr = 'instr_nClass') { - ## Presumably this will have access to derive class' `calc_one`? + ## Presumably this will have access to derived class' `calc_one`? return(calc_one(0)) ## calc_one will always has `idx` as arg? }, returnType = 'numericScalar' ), @@ -59,11 +59,11 @@ declFxnBase_nClass <- nClass( ## We haven't dealt with ensuring a virtual destructor when any method is virtual ## For now I did it manually by editing the .h and .cpp predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> - file.path("declFxnBase_nC")), + file.path("declFunBase_nC")), compileInfo=list(interface="full", createFromR = FALSE, - exportName = "declFxnBase_nClass_new", - needed_units = list("nodeInstr_nClass"), - packageNames = c(uncompiled="declFxnBase_nClass_R", compiled="declFxnBase_nClass") + exportName = "declFunBase_nClass_new", + needed_units = list("instr_nClass"), + packageNames = c(uncompiled="declFunBase_nClass_R", compiled="declFunBase_nClass") ) ) diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index d48776b..aaa2ba4 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -46,7 +46,7 @@ range2instr <- function(range) { } ## Eventually think about reordering order of looping for efficiency (and take parallelization into account). -## For the moment, we determine mat vs. seq here and then in declClass calculate we will determine whether to +## For the moment, we determine mat vs. seq here and then in declFunClass calculate we will determine whether to ## vectorize based on whether possible based on the declaration. ## Open question of when to determine if to use parallel calculate. determineInstrType <- function(instr, use_vec = FALSE) { @@ -83,6 +83,7 @@ determineInstrType <- function(instr, use_vec = FALSE) { return(type2itype[[type]]) } +#' @export makeInstrList <- function(model, varRanges, use_vec = FALSE) { if(missing(varRanges)) varRanges <- model$getVarNames() @@ -98,8 +99,9 @@ makeInstrList <- function(model, varRanges, use_vec = FALSE) { instrList <- nList(instr_nClass)$new() numRanges <- length(ranges) instrList$setLength(numRanges) + ord <- order(unlist(lapply(ranges, function(x) x$sortID))) for(i in 1:numRanges) - instrList[[i]] <- instr_nClass$new(ranges[[i]]) + instrList[[i]] <- instr_nClass$new(ranges[[ord[i]]]) return(instrList) } @@ -132,9 +134,12 @@ instr_nClass <- nClass( type = 'integerScalar', sortID = 'integerVector', declID = 'integerScalar' - ), compileInfo = list(interface = "full") # TODO: check on this. + ), compileInfo = list(interface = "full", + createFromR = FALSE, + exportName = "instr_nClass_new", + packageNames = c(uncompiled="instr_nClass_R", compiled="instr_nClass") + ) ) -## TODO: determine how to handle this in terms of it being a predefined nClass -## TODO: see PdV version and determine what `compileInfo` elements are needed. + diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 90abf31..ca3b257 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -20,49 +20,45 @@ modelBase_nClass <- nClass( }, getDependencies = function(nodes, self = TRUE, downstream = FALSE, immediateOnly = FALSE) { nimbleModel:::getDependencies(modelDef, nodes, self, downstream, immediateOnly) + }, + calculate = function(instrList) { + if(inherits(instrList, 'instr_nClass')) { + oneInstr <- instrList + instrList <- nList(instr_nClass)$new() + instrList$setLength(1) + instrList[[1]] <- oneInstr + } + if(!((inherits(instrList, 'nList') || is.list(instrList)) && inherits(instrList[[1]], 'instr_nClass'))) + instrList <- makeInstrList(self, instrList) + ## Assume instrList is ordered (it is done `makeInstrList`). + if(isCompiled()) + return(calculate_impl(instrList)) + logProb <- 0 + for(i in 1:length(instrList)) { + logProb <- logProb + declFunList[[instrList[[i]]$declID]]$calculate(instrList[[i]]) + } + return(logProb) } ), Cpublic = list( - declList = 'nList(declFxnBase_nClass)', + declFunList = 'RcppObject', # This won't actually be used in C++, but needs to be in Cpublic for accessibility. + declFunMapping = 'RcppList', # Not sure what type this should be for use in C++. ping = nFunction( name = "ping", function() {return(TRUE); returnType(logical())}, compileInfo = list(virtual=TRUE) ), - calculate = nFunction( - ## TODO: What is the difference between having this as Cpublic with separate C_fun and having in R_public? - name = "calculate", + calculate_impl = nFunction( + name = "calculate_impl", function(instrList) { - cat("In uncompiled calculate\n") - if(inherits(instrList, 'instr_nClass')) - instrList <- list(instrList) - if(FALSE) { - ## TODO: self is a Cpub_uncompiled obj, not full specialized model class. - ## So this doesn't work as we need self$modelDef in `makeInstrList()`. - if(!(is.list(instrList) && inherits(instrList[[1]], 'instr_nClass'))) - instrList <- makeInstrList(self, instrList) - } - logProb <- 0 - ord <- order(unlist(lapply(instrList, function(x) x$sortID))) - ## This is where uncompiled stepping through the calcInstrList happens. - for(i in 1:length(ord)) { - ## TODO: need to sort out this lookup process. - ## nodeIdx <- instr$declID - ## nodemember_name <- self$nodeObjNames[nodeIdx] # nodeObjNames is found in the derived class - logProb <- logProb + declList[[instrList[[ord[i]]]$declID]]$calculate(instrList[[ord[i]]]) - } - return(logProb) + cat("Uncompiled `calculate_impl` should never be called.\n") + return(0) }, returnType = 'numericScalar', compileInfo = list( - C_fun = function(instrList='nList(instr_nClass)') { - logProb <- 0 - ## For now assuming instructions are in order. - for(i in 1:length(instrList)) { - ## nodemember_name <- self$nodeObjNames[instrList[[i]]$declID] - logProb <- logProb + declList[[instrList[[i]]$declID]]$calculate(instrList[[i]]) - } - return(logProb) + C_fun = function(instrList = 'nList(instr_nClass)') { + ## TODO: consider whether instrList will be ordered and/or how C++ will see the decl indexing info. + cppLiteral('modelClass_::calculate(instrList);') }, virtual=TRUE ) @@ -72,8 +68,8 @@ modelBase_nClass <- nClass( predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("modelBase_nC")), compileInfo=list(interface="full", createFromR = FALSE, - Hincludes = c('"declFxnBase_nClass_c_.h"'), #, '"calcInstrList_nClass_c_.h"'), # "declFxnBase_nClass_c_.h" needed for package = TRUE - needed_units = list("declFxnBase_nClass","instr_nClass"), + Hincludes = c('"declFunBase_nClass_c_.h"'), + needed_units = list("declFunBase_nClass","instr_nClass"), exportName = "modelBase_nClass_new", packageNames = c(uncompiled="modelBase_nClass_R", compiled="modelBase_nClass") ) diff --git a/nimbleModel/R/modelDecl.R b/nimbleModel/R/modelDecl.R index 685279a..95cde1b 100644 --- a/nimbleModel/R/modelDecl.R +++ b/nimbleModel/R/modelDecl.R @@ -118,7 +118,7 @@ modelDeclClass <- R6Class( ## Create declRule and symbolic RHS pieces. processDecl = function(nimFunNames, constants = list(), envir) { - declRule <<- declRuleClass$new(self, sourceLineNumber, context, constants) + declRule <<- declRuleClass$new(self, 0, context, constants) makeSymbolicParentNodes(nimFunNames, constants, envir) invisible(NULL) }, diff --git a/nimbleModel/R/modelDef.R b/nimbleModel/R/modelDef.R index ea3d231..aaadc72 100644 --- a/nimbleModel/R/modelDef.R +++ b/nimbleModel/R/modelDef.R @@ -16,6 +16,8 @@ modelDefClass <- R6Class( contexts = list(), constants = list(), declInfo = list(), + declFunNameToIndex = list(), + declFunIndexToName = NULL, downstreamRules = NULL, upstreamRules = NULL, calcRules = NULL, @@ -53,6 +55,7 @@ modelDefClass <- R6Class( addRemainingDotParams() ## Add additional altParams as needed. replaceAllConstants() ## Simplify expressions introduced in `addRemainingDotParams`. processDecls(userEnv) ## Create declRules and set up symbolicParentNodes (and flags dynamic indexing). + assignDeclIDs() ## Set sequential declID values and declFun mapping. genAltParams() ## Create altParam expressions and create `calculateCode` (without altParams). genBounds() ## Create bound expressions (modifying `calculateCode`). @@ -546,6 +549,13 @@ modelDefClass <- R6Class( invisible(NULL) }, + assignDeclIDs = function() { + for(i in seq_along(declInfo)) + declInfo[[i]]$declRule$ID <- as.character(i) + declFunNameToIndex <<- as.list(1:length(declInfo)) + names(declFunNameToIndex) <<- paste("declFun", 1:length(declInfo), sep = "_") + }, + ## Add additional altParams not already addressed in getting canonical params. addRemainingDotParams = function() { for(iDecl in seq_along(declInfo)) { diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index 0221df6..03952f0 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -2,6 +2,7 @@ ## but with nCompiler, we need a modelClass to compile and then we can create an instance. ## If we create an instance as the output here, one can't then compile that with an algorithm via `nCompile`. ## Need to think more about the workflow for nimble 2.0. +#' @export nimbleModel <- function(code, constants = list(), data = list(), @@ -17,41 +18,39 @@ nimbleModel <- function(code, buildDerivs = getNimbleOption('buildModelDerivs'), userEnv = parent.frame()) { ## TODO: arg list taken from `nimble`. Revisit which options are needed. - ## For the moment this goes through nimbleModel R6 class and then nCompiler class. Clean that up once ideas are in place. + ## For the moment this goes through (original) nimbleModel R6 class and then nimbleModel nClass. Clean that up once ideas are in place. ## Presumably everything would be in Rpublic initialize for modelBaseClass, so this function will just call modelBase_nClass$new(). - m <- modelClass$new(name = name, code = code, constants = constants, data = data, inits = inits, dimensions = dimensions, userEnv = userEnv) - modelClassInstance <- make_modelClass_from_nimbleModel(m) - if(compile) modelClassInstance <- nCompile(modelClassInstance) - if(returnClass) return(modelClassInstance) # Standard use for when compiling a model(class) and algo(class) together. - model <- modelClassInstance$new() # Otherwise return model object for manipulation from R. + nm <- modelClass$new(name = name, code = code, constants = constants, data = data, inits = inits, dimensions = dimensions, userEnv = userEnv) + specificModelClass <- make_modelClass_from_nimbleModel(nm) + if(compile) specificModelClass <- nCompile(specificModelClass) + if(returnClass) return(specificModelClass) # Standard use for when compiling a model(class) and algo(class) together. + model <- specificModelClass$new() # Otherwise return model object for manipulation from R. } make_modelClass_from_nimbleModel <- function(m, compile=FALSE) { mDef <- m$modelDef - allVarInfo <- get_varInfo_from_nimbleModel(m) - modelVarInfo <- allVarInfo$vars - declFxnNames <- character() + modelVarInfo <- get_varInfo_from_nimbleModel(m) declInfoList <- list() - declFxnList <- list() + declFunClassList <- list() # two vectors for canonical use for calculation instructions # to move between names and indices of declFxns: + declFunNames <- names(mDef$declFunNameToIndex) for(i in seq_along(mDef$declInfo)) { declInfo <- mDef$declInfo[[i]] decl_methods <- make_decl_methods_from_declInfo(declInfo) declVars <- decl_methods |> lapply(\(x) all.vars(body(x))) |> unlist() |> unique() |> setdiff(c("idx", "LocalNewLogProb_", "LocalAns_", "model")) %||% character() - declVarInfo <- modelVarInfo[declVars] - SLN <- declInfo$sourceLineNumber - decl_classname <- paste0("declClass_", SLN) # name of an nClass generator - decl_RvarName <- paste0("declFxn_", SLN) # name of an R variable holding the nClass generator - decl_membername <- paste0("decl_", SLN) # name of model member variable holding an instance of the nClass - # Currently, we can't just make a list of these but need them as named objects in the environment - declFxnList[[decl_RvarName]] <- make_declFxn_nClass(declVarInfo, decl_methods, decl_classname) - assign(decl_RvarName, - declFxnList[[decl_RvarName]] - ) - declInfoList[[i]] <- make_decl_info_for_model_nClass(decl_membername, decl_RvarName, decl_classname, declVarInfo) + declVarInfo <- modelVarInfo$vars[declVars] + declID <- as.numeric(declInfo$declRule$ID) # Formerly `sourceLineNumber`, which may not be unique. + declFun_membername <- declFunNames[i] + declFun_classname <- sub("declFun", "declFunClass", declFun_membername) # name of an nClass generator + declFun_RvarName <- sub("declFun", "declFunClassGen", declFun_membername) # name of R var holding the nClass generator + # Currently, we can't just make a list of these but need them as named objects in the environment, + # which is passed into the nClass() call so that `initialize()` can use them via R's scoping. + assign(declFun_RvarName, make_declFun_nClass(declVarInfo, decl_methods, declFun_classname, declID)) + declInfoList[[i]] <- make_decl_info_for_model_nClass(declFun_membername, declFun_RvarName, declFun_classname, declVarInfo) } - modelClassInstance <- makeModel_nClass(modelVarInfo, declInfoList, inits = m$origInits, data = m$origData, model = m, classname = "my_model", env = environment()) + modelClassInstance <- makeModel_nClass(modelVarInfo, declInfoList, inits = m$origInits, data = m$origData, + model = m, classname = "my_model", env = environment()) } @@ -79,10 +78,11 @@ nm_addModelDollarSign <- function(expr, exceptionNames = character(0)) { return(expr) } -# Turn variables and methods into a declFxn nClass -make_declFxn_nClass <- function(varInfo = list(), +# Turn variables and methods into a declFun nClass +make_declFun_nClass <- function(varInfo = list(), methods = list(), - classname) { + classname, + declID) { # varInfo will be a list (names not used) of name, nDim, sizes. # These are the model member variables to be used by the declFxn. # They will be used in a constructor to set up C++ references to model variables. @@ -115,10 +115,11 @@ make_declFxn_nClass <- function(varInfo = list(), } else { initializersList <- character() } + ## TODO: I don't think this labelCreator (or the one for the model) exist (though they shouldn't be used...) if(missing(classname)) - classname <- declFxnLabelCreator() + classname <- declLabelCreator() - baseclass <- paste0("declFxnClass_<", classname, ">") + baseclass <- paste0("declFunClass_<", classname, ">") # Rpublic method to set the model pointer/reference. setModel <- function(model) { @@ -131,9 +132,9 @@ make_declFxn_nClass <- function(varInfo = list(), } # This was a prototype - declFxn_nClass <- substitute( + declFun_nClass <- substitute( nClass( - inherit = declFxnBase_nClass, + inherit = declFunBase_nClass, classname = CLASSNAME, Rpublic = RPUBLIC, Cpublic = CPUBLIC, @@ -143,6 +144,7 @@ make_declFxn_nClass <- function(varInfo = list(), ), list( CPUBLIC = c( + declID = declID, list( nFunction( initFun, @@ -158,40 +160,39 @@ make_declFxn_nClass <- function(varInfo = list(), CLASSNAME = classname, BASECLASS = baseclass )) - eval(declFxn_nClass) + eval(declFun_nClass) } #test <- nCompiler:::type2symbol('CppVar(baseType = type2cpp("numericVector"), ref=TRUE, const=TRUE)') # Make all the info needed to include a decl in a model class. -# The declFxn_nClass should be created first. +# The decl_nClass should be created first. # Currently it needs to have a name to include in nCompile(). Later we might be able to pass the object itself # At first drafting this is fairly trivial but could grow in complexity. make_decl_info_for_model_nClass <- function(membername, - declFxnName, + declFunName, classname, varInfo = list() ) { ctorArgs <- varInfo |> lapply(\(x) x$name) |> unlist() - list(declFxnName = declFxnName, + list(declFunName = declFunName, membername = membername, classname = classname, ctorArgs = ctorArgs) } -makeModel_nClass <- function(varInfo, +makeModel_nClass <- function(modelVarInfo, decls = list(), classname, - sizes = list(), inits = list(), data = list(), model = NULL, env = parent.frame() ) { - # varInfo will be a list (names not used) of name, nDim, sizes. - CpublicModelVars <- varInfo |> lapply(\(x) paste0("numericArray(nDim=",x$nDim,")")) - names(CpublicModelVars) <- varInfo |> lapply(\(x) x$name) |> unlist() + ## varInfo will be a list (names not used) of name, nDim, sizes. + CpublicModelVars <- modelVarInfo$vars |> lapply(\(x) paste0("numericArray(nDim=",x$nDim,")")) + names(CpublicModelVars) <- modelVarInfo$vars |> lapply(\(x) x$name) |> unlist() opDefs <- list( base_ping = nCompiler:::getOperatorDef("custom_call"), setup_decl_mgmt = nCompiler:::getOperatorDef("custom_call"), @@ -236,26 +237,21 @@ makeModel_nClass <- function(varInfo, resize_from_list = nFunction( name = "resize_from_list", function(Rlist) {for(v in names(Rlist)) - if(exists(v, self, inherits=FALSE)) self[[v]] <- nArray(dim=Rlist[[v]])}, + if(exists(v, self, inherits=FALSE)) self[[v]] <- nArray(value = NA, dim=Rlist[[v]])}, compileInfo = list( C_fun=function(Rlist = 'RcppList') {cppLiteral('modelClass_::resize_from_list(Rlist);')}) ) ) - # decls will be a list of membername, declFxnName, (decl) classname, ctorArgs (list) + # decls will be a list of membername, declName, (decl) classname, ctorArgs (list) decl_pieces <- decls |> lapply(\(x) { #nClass_type <- paste0(x$declFxnName, "()") init_string <- paste0('nCpp("', x$membername, '( new ', x$classname, '(', paste0(x$ctorArgs, collapse=","), '))")') - list(nClass_type = x$declFxnName, - init_string = init_string, - membername = x$membername) + list(nClass_type = x$declFunName, + init_string = init_string) }) - declObjNames <- (decl_pieces |> lapply(\(x) x$membername) |> unlist()) %||% character() - # declObjNames also serves for canonical lookup of names by index. - # e.g. declObjNames[i] gives the member name of the index=i decl member. - declObjName_2_declIndex <- seq_along(declObjNames) |> structure(names=declObjNames) - # Inversely, declobjName_2_declIndex["decl_3"] gives the index of that decl. - CpublicDeclFuns <- decl_pieces |> lapply(\(x) x$nClass_type) |> setNames(declObjNames) + + CpublicDeclFuns <- decl_pieces |> lapply(\(x) x$nClass_type) |> setNames(names(model$modelDef$declFunNameToIndex)) # CpublicDeclFuns <- list( # beta_decl = 'decl_dnorm()' # ) @@ -272,33 +268,51 @@ makeModel_nClass <- function(varInfo, # here is a magic flag. if(isTRUE(.GlobalEnv$.debugModelInit)) browser() super$initialize() - if(isCompiled()) - self$setup_decl_mgmt_from_names(self$declObjNames) - if(!isCompiled()) { - for(declObj in self$declObjNames) { - self[[declObj]] <- eval(as.name(self$CpublicDeclFuns[[declObj]]))$new() - self[[declObj]]$setModel(self) + ## TODO: figure out which of the following to the base class initialize. + ## For now just putting these here in one place. + declFunNames <- names(self$declFunNameToIndex) + if(isCompiled()) { + self$setup_decl_mgmt_from_names(declFunNames) + } else { + self$declFunList <- list() + length(self$declFunList) <- length(declFunNames) + names(self$declFunList) <- declFunNames + for(declFunName in declFunNames) { + self[[declFunName]] <- eval(as.name(self$CpublicDeclFuns[[declFunName]]))$new() + self[[declFunName]]$setModel(self) + self$declFunList[[self$declFunNameToIndex[[declFunName]]]] <- self[[declFunName]] } } + + ## TODO: create a merge_and_set function that handles all three of the following. - # First expand any provided or default sizes - # To-Do possibly merge the argument sizes and defaultSizes by element. - if(missing(sizes)) sizes <- self$defaultSizes - if(length(sizes)) resize_from_list(sizes) - - # Then any provided inits over-ride any provided sizes - # To-Do: Ditto - if(missing(inits)) inits <- self$defaultInits + allSizes <- self$defaultSizes + if(!missing(sizes)) + for(nm in names(sizes)) + allSizes[[nm]] <- sizes[[nm]] + ## TODO: should we handle 0-dim sizes elsewhere? + allSizes <- allSizes[sapply(allSizes, length) > 0] + if(length(allSizes)) resize_from_list(allSizes[sapply(allSizes, length) > 0]) + + allInits <- self$defaultInits + if(!missing(inits)) + for(nm in names(inits)) + allInits[[nm]] <- inits[[nm]] + if(length(allInits)) set_from_list(allInits) + + if(missing(inits)) { + allInits <- self$defaultInits + } else if(length(inits)) set_from_list(inits) # TODO: do we want to handle data differently? # TODO: need to work through not setting as 'data' if values are NA; # check back against how dataRules work in nimbleModel work. - if(missing(data)) data <- self$defaultData - if(length(data)) set_from_list(data) -browser() - - + allData <- self$defaultData + if(!missing(inits)) + for(nm in names(inits)) + allData[[nm]] <- inits[[nm]] + if(length(allData)) set_from_list(allData) } baseclass <- paste0("modelClass_<", classname, ">") # CpublicDeclFuns has elements like "decl_1 = quote(declFxn_1())" @@ -311,7 +325,7 @@ browser() classname = CLASSNAME, inherit = modelBase_nClass, compileInfo = list(opDefs = OPDEFS, - nClass_inherit = list(base=BASECLASS)#, + nClass_inherit = list(base=BASECLASS) #, # needed_units = list("declFxnBase_nClass"), # needed for package=TRUE # Hincludes = '"declFxnBase_nClass_c_.h"' # needed for package=TRUE ), @@ -322,9 +336,8 @@ browser() list(OPDEFS = opDefs, # A list of individual elements RPUBLIC = list(initialize=initialize, - declObjNames = declObjNames, - declObjName_2_declIndex = declObjName_2_declIndex, - defaultSizes = sizes, + declFunNameToIndex = model$modelDef$declFunNameToIndex, + defaultSizes = modelVarInfo$sizes, defaultInits = inits, defaultData = data, modelDef = model$modelDef, @@ -346,6 +359,8 @@ get_varInfo_from_nimbleModel <- function(model) { logProbVars <- mDef$logProbVarInfo |> extract() # The resize_from_list method will error out if a scalar is included. # The maxs is empty for scalars, so they are automatically omitted from the sizes result here. + # TODO: CJP sees scalars included as numeric(0) in sizes, so not omitted. Will this be a problem for resize_from_list? + # TODO: If ok, put sizes info into the same list as vars info. extract_sizes <- \(x) x|> lapply(\(x) x$maxs) sizes <- mDef$varInfo |> extract_sizes() logProb_sizes <- mDef$logProbVarInfo |> extract_sizes() diff --git a/nimbleModel/R/nodeRules.R b/nimbleModel/R/nodeRules.R index 42652e3..db65d4b 100644 --- a/nimbleModel/R/nodeRules.R +++ b/nimbleModel/R/nodeRules.R @@ -127,11 +127,6 @@ declRuleClass <- R6Class( originalIndexingRule = NULL, # Determines original indexing (based on context). decl = NULL, # Full declInfo; nodeRuleClass$expr is just LHS. calculate = NULL, # Generic function for calculation. - ID = NULL, # Unique ID that will be the index of the declClass in C++ (TBD how this is baked in). - ## TODO: remove this: - test = rep(0, 10), ## test element used for testing calculation while modelDef doesn't have acccess to a model - test2 = matrix(0, 3, 5), - initialize = function(decl, ID, context = modelContextClass$new(), constants = list()) { decl <<- decl super$initialize(decl$code[[2]], ID, context = context, constants = constants) @@ -240,7 +235,7 @@ calcRuleClass <- R6Class( indexingRange <- declRule$originalIndexingRule$apply(inputRange) if(is.null(indexingRange)) return(NULL) - result <- calcRangeClass$new(varName, indexingRange, declRule$ID, sortID, multiSortIDindex) + result <- calcRangeClass$new(varName, indexingRange, as.numeric(declRule$ID), sortID, multiSortIDindex) return(result) }, diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index d6906c2..376e973 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -207,31 +207,33 @@ if(FALSE) { ## CJP experimentation with nimbleModel, modelClass stuff. library(nimbleModel);library(nCompiler) -# source('modelBaseClass.R') -# source('declFxnBaseClass.R') -# source('nimbleModel.R') -# source('instructions.R') - code <- quote({ sd ~ dunif(0, 10) for(i in 1:5) { - z[i] <- x[i+1] + 10 + # z[i] <- x[i+1] + 10 y[i] ~ dnorm(x[i+1], sd = sd) } }) + inits <- list(sd = 1.5) data <- list(y = rnorm(5)) nm <- modelClass$new(code, inits = inits, data = data) mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) -m <- mclass$new(inits=list(sd=5)) -## m$calculate('sd') # Doesn't work because Cpublic calculate can't run makeInstrList as it can't access modelDef. +# .debugModelInit <- TRUE +m <- mclass$new(inits=list(sd=5, x = rnorm(6))) -instrList <- nimbleModel:::makeInstrList(m, 'sd') +m$calculate('sd') +instrList <- makeInstrList(m, 'sd') +m$calculate(instrList) +instrList <- makeInstrList(m, 'y') m$calculate(instrList) -instrList <- nimbleModel:::makeInstrList(m, 'y') + +instrList <- makeInstrList(m, c('y','sd')) # ordering should be done internally m$calculate(instrList) +m$calculate(c('y','sd')) # ordering should be done internally + # cr <- m$modelDef$calcRules[['y']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['y']]$rules[[1]]$apply('y')) # cr <- m$modelDef$calcRules[['sd']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['sd']]$rules[[1]]$apply('sd')) @@ -240,7 +242,14 @@ out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calc_one(0) out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calc_0(instrList[[1]]) out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calculate(instrList[[1]]) -# how initialize a list of declFxns? +mclass <- nimbleModel(code, data = data, inits = inits) +m <- mclass$new(inits=list(sd=5, x = rnorm(6))) +m$calculate(c('y','sd')) + +m <- nimbleModel(code, data = data, inits = inits, returnClass = FALSE) + +## Try out compilation; see nCompiler's test-nimbleModel.R. + # How get nCompiler to know about base class not in nCompiler? # tmp=nList(nimbleModel:::declFxnBase_nClass) @@ -273,7 +282,3 @@ obj$myfun(3) ## full workflow with getDeps -## work on sortID - - - From c2df1d706b6f5a892664870af48eef575d692026 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 09:40:36 -0700 Subject: [PATCH 03/32] Cleanup stuff related to modelClass and modelBaseClass. --- nimbleModel/R/model.R | 13 ++-- nimbleModel/R/modelBaseClass.R | 15 ++++- nimbleModel/R/modelDecl.R | 6 +- nimbleModel/R/modelDef.R | 8 --- nimbleModel/R/nimbleModel.R | 5 +- nimbleModel/R/nodeRules.R | 59 +------------------ nimbleModel/tests/testthat/test-nimbleModel.R | 4 +- 7 files changed, 30 insertions(+), 80 deletions(-) diff --git a/nimbleModel/R/model.R b/nimbleModel/R/model.R index 2dc0b64..4bdc65d 100644 --- a/nimbleModel/R/model.R +++ b/nimbleModel/R/model.R @@ -2,6 +2,12 @@ ## static information, data information, and methods for querying the model ## structure. +## For the moment this overlaps with the custom model class we create +## for each model using nCompiler. That model class takes some of the +## fields and calls some of the methods set up here. + +## TODO: possibly work all of this into modelBase_nClass. + ## Will need to do some work to extend this to get full current behavior ## where the model is created by `nimbleModel` and the custom model class ## contains fields for the different variables. @@ -67,11 +73,6 @@ modelClass <- R6Class( makeDataRules(data) makePredictiveRules() - - ## Do this once we have a custom model class with fields we can assign into. - ## setData(data) - ## setInits(inits) - }, makeDataRules = function(data) { @@ -126,7 +127,7 @@ modelClass <- R6Class( nonpredictiveRules <<- candidateRules }, - + ## TODO: should this be a standalone function like getNodes, getDependencies? getVarNames = function(includeLogProb = FALSE, nodeRanges) { if(missing(nodeRanges)){ if(includeLogProb) return(modelDef$varNames) diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index ca3b257..148b0fe 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -2,7 +2,6 @@ modelBase_nClass <- nClass( classname = "modelBase_nClass", Rpublic = list( - ## TODO: bring in methods and fields from nimbleModel:::modelClass. modelDef = NULL, dataRules = NULL, nondataRules = NULL, @@ -19,8 +18,20 @@ modelBase_nClass <- nClass( } }, getDependencies = function(nodes, self = TRUE, downstream = FALSE, immediateOnly = FALSE) { - nimbleModel:::getDependencies(modelDef, nodes, self, downstream, immediateOnly) + nimbleModel::getDependencies(modelDef, nodes, self, downstream, immediateOnly) }, + getParents = function(nodes, self = TRUE, upstream = FALSE, immediateOnly = FALSE) { + nimbleModel::getParents(modelDef, nodes, self, upstream, immediateOnly) + }, + getNodes = function(nodes, stochOnly = FALSE, determOnly = FALSE, + includeData = TRUE, dataOnly = FALSE, + includePredictive = TRUE, predictiveOnly = FALSE, + includeRHSonly = FALSE, + topOnly = FALSE, latentOnly = FALSE, endOnly = FALSE) { + nimbleModel::getNodes(modelDef, stochOnly, determOnly, includeData, dataOnly, + includePredictive, predictiveOnly, includeRHSonly, + topOnly, latentOnly, endOnly) + }, calculate = function(instrList) { if(inherits(instrList, 'instr_nClass')) { oneInstr <- instrList diff --git a/nimbleModel/R/modelDecl.R b/nimbleModel/R/modelDecl.R index 95cde1b..3ab444c 100644 --- a/nimbleModel/R/modelDecl.R +++ b/nimbleModel/R/modelDecl.R @@ -8,7 +8,7 @@ modelDeclClass <- R6Class( public = list( context = NULL, # FUTURE: might just use declRule$context sourceLineNumber = NULL, - stoch = FALSE, # Need this here as used before declRule created. + stoch = FALSE, code = NULL, distributionName = NA, valueExpr = NULL, @@ -283,10 +283,6 @@ modelDeclClass <- R6Class( invisible(NULL) }, - buildFunctions = function() { - declRule$buildFunctions(calculateCode, genLogProbExpr()) - }, - genLogProbExpr = function() { if(declRule$decl$stoch) { logProbExpr <- code[[2]] diff --git a/nimbleModel/R/modelDef.R b/nimbleModel/R/modelDef.R index aaadc72..a41e155 100644 --- a/nimbleModel/R/modelDef.R +++ b/nimbleModel/R/modelDef.R @@ -76,7 +76,6 @@ modelDefClass <- R6Class( warnRHSonlyDynamicIndexing() - buildFunctions() ## Generate calculate and other functions. invisible(NULL) }, @@ -877,13 +876,6 @@ modelDefClass <- R6Class( } } invisible(NULL) - }, - - buildFunctions = function() { - for(i in seq_along(declInfo)) { - declInfo[[i]]$buildFunctions() - } - invisible(NULL) } ) ) diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index 03952f0..b4b03b5 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -341,7 +341,10 @@ makeModel_nClass <- function(modelVarInfo, defaultInits = inits, defaultData = data, modelDef = model$modelDef, - ## TODO: add other fields from `nimbleModel::modelClass` such as dataRules, predictiveRules, etc. + dataRules = model$dataRules, + nondataRules = model$nondataRules, + predictiveRules = model$predictiveRules, + nonpredictiveRules = model$nonpredictiveRules, CpublicDeclFuns = CpublicDeclFuns), # A concatenation of lists CPUBLIC = c(CpublicDeclFuns, CpublicModelVars, CpublicCtor, CpublicMethods), diff --git a/nimbleModel/R/nodeRules.R b/nimbleModel/R/nodeRules.R index db65d4b..f1f51f8 100644 --- a/nimbleModel/R/nodeRules.R +++ b/nimbleModel/R/nodeRules.R @@ -7,18 +7,12 @@ ## rather it simply represents the valid index values for a variable. ## There is one declRule for each declaration in a model, representing the indexing for the LHS variable. -## A declRule contains the `calculate` function (i.e., the nodeFunction) that operates on a -## single set of index values. ## calcRules are generated by starting with declRules and then fracturing (with `fracture`) ## based on top-down processing. This produces a calcRule for each set of nodes ## from a declaration that can be calculated together (same sortID) ## (as well as the special case of state-space model type formulations). -## TODO: work on `simulate`, `getParam` and other related model methods; will these be part or -## `calcRules`? - - ## Base class for all node-related classes nodeRuleClass <- R6Class( classname = "nodeRuleClass", @@ -117,8 +111,7 @@ nodeRuleClass <- R6Class( ) ) -## Class for representing nodes at the declaration level, containing -## calculate and other nodeFunctions. +## Class for representing nodes at the declaration level. declRuleClass <- R6Class( classname = "declRuleClass", portable = FALSE, @@ -126,61 +119,13 @@ declRuleClass <- R6Class( public = list( originalIndexingRule = NULL, # Determines original indexing (based on context). decl = NULL, # Full declInfo; nodeRuleClass$expr is just LHS. - calculate = NULL, # Generic function for calculation. initialize = function(decl, ID, context = modelContextClass$new(), constants = list()) { decl <<- decl super$initialize(decl$code[[2]], ID, context = context, constants = constants) ## `expr` in is parent class. originalIndexingRule <<- originalIndexingRuleClass$new(expr, context, constants) - }, - - buildFunctions = function(code, logProbExpr) { - buildCalculateFun(code, logProbExpr, context) - }, - - buildCalculateFun = function(code, logProbExpr, context) { - newCode <- code - if(newCode[[1]] == '<-') { - newCode <- quote(A <<- B) - newCode[2:3] <- code[2:3] - } - replacements <- sapply(seq_along(context$singleContexts), - function(i) parse(text = paste0('idx[',i,']'))[[1]]) - names(replacements) <- context$indexVarNames - - for(i in seq_along(context$singleContexts)) { - newCode <- eval(substitute(substitute(e, replacements), list(e = newCode))) - logProbExpr <- eval(substitute(substitute(e, replacements), list(e = logProbExpr))) - } - - if(decl$stoch) { - ## Insert 'logProb_' and change to assignment, moving LHS in as first argument. - finalCode <- quote(A <<- B) - finalCode[[2]] <- logProbExpr - finalCode[[3]] <- newCode[[3]] - len <- length(finalCode[[3]]) - if(len > 1) { - finalCode[[3]][3:(len+1)] <- finalCode[[3]][2:len] - names(finalCode[[3]])[3:(len+1)] <- names(finalCode[[3]])[2:len] - } - finalCode[[3]][[2]] <- newCode[[2]] - names(finalCode[[3]])[2] <- "" - finalCode[[3]][[len+2]] <- 1 - names(finalCode[[3]])[len+2] <- "log" - calculate <<- function(idx) { - ## logProb_y <- array(0, rep(100, nvals)) # TODO: placeholder so logProb storage exists for testing - } - ## body(calculate)[[length(body(calculate))+1]] <<- finalCode - body(calculate) <<- finalCode - } else { - calculate <<- function(idx) {} - body(calculate) <<- newCode - } - ## TODO: will need to deal with logProb for mv node having single value inserted. - ## TODO: will need to deal with the various complexities we currently deal with - alt params, truncation, etc. } - ) ) @@ -381,7 +326,7 @@ calcRuleClass <- R6Class( ) ## calcRanges manage the calculation for one or more nodes, handling the indexing, and -## calling out to the declRule `calculate` function. +## calling out to the declFun `calculate` function. calcRangeClass <- R6Class( classname = "calcRangeClass", portable = FALSE, diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 376e973..a8262a2 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -248,6 +248,9 @@ m$calculate(c('y','sd')) m <- nimbleModel(code, data = data, inits = inits, returnClass = FALSE) +m$calculate(m$getDependencies('sd')) + + ## Try out compilation; see nCompiler's test-nimbleModel.R. @@ -280,5 +283,4 @@ obj$pop(rnorm(3),rnorm(5)) obj$myfun(3) -## full workflow with getDeps From 37f24d4bd52ac4fe7ac40963f9fa6146ab941b03 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 10:12:44 -0700 Subject: [PATCH 04/32] Add simulate declFun. --- nimbleModel/R/declFunBaseClass.R | 41 ++++++++++++++++++- nimbleModel/R/modelBaseClass.R | 38 +++++++++++++++-- nimbleModel/R/modelDef.R | 4 ++ nimbleModel/tests/testthat/test-nimbleModel.R | 7 +++- 4 files changed, 84 insertions(+), 6 deletions(-) diff --git a/nimbleModel/R/declFunBaseClass.R b/nimbleModel/R/declFunBaseClass.R index 1f66749..e269dd0 100644 --- a/nimbleModel/R/declFunBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -20,11 +20,9 @@ declFunBase_nClass <- nClass( }, returnType = 'numericScalar', compileInfo = list(virtual=TRUE) ), - ## TODO: for all these type-specific calculates, how do we call the methods of the decl_nClass object? calc_0 = nFunction( name = 'calc_0', function(instr = 'instr_nClass') { - ## Presumably this will have access to derived class' `calc_one`? return(calc_one(0)) ## calc_one will always has `idx` as arg? }, returnType = 'numericScalar' ), @@ -54,6 +52,45 @@ declFunBase_nClass <- nClass( logProb <- logProb + calc_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? return(logProb) }, returnType = 'numericScalar' + ), + + simulate = nFunction( + name = "simulate", + fun = function(instr = 'instr_nClass') { + ## TODO: how embed determination of vec and parallel cases here? + if(instr$type == 0) return(sim_0(instr)) + if(instr$type == 1) return(sim_1_seq(instr)) + if(instr$type == 2) return(sim_1_mat(instr)) + if(instr$type == 3) return(sim_1_matp(instr)) + }, + compileInfo = list(virtual=TRUE) + ), + sim_0 = nFunction( + name = 'sim_0', + function(instr = 'instr_nClass') { + sim_one(0) ## sim_one will always has `idx` as arg? + } + ), + sim_1_seq = nFunction( + name = 'sim_1_seq', + function(instr = 'instr_nClass') { + for(i in 1:instr$lens[1]) + sim_one(instr$values[[1]][1]+i) + } + ), + sim_1_mat = nFunction( + name = 'sim_1_mat', + function(instr = 'instr_nClass') { + for(i in 1:instr$lens[1]) + sim_one(instr$values[[1]][i]) + } + ), + sim_1_matp = nFunction( + name = 'sim_1_mat', + function(instr = 'instr_nClass') { + for(i in 1:instr$lens[1]) + sim_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + } ) ), ## We haven't dealt with ensuring a virtual destructor when any method is virtual diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 148b0fe..58412d5 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -23,12 +23,14 @@ modelBase_nClass <- nClass( getParents = function(nodes, self = TRUE, upstream = FALSE, immediateOnly = FALSE) { nimbleModel::getParents(modelDef, nodes, self, upstream, immediateOnly) }, - getNodes = function(nodes, stochOnly = FALSE, determOnly = FALSE, + ## TODO: not working because `nimbleModel::getNodes` needs the model not just modelDef. + ## Once we integrate modelClass with modelBase_nClass, we should be able to pass `self`. + getNodes = function(nodes = NULL, stochOnly = FALSE, determOnly = FALSE, includeData = TRUE, dataOnly = FALSE, includePredictive = TRUE, predictiveOnly = FALSE, includeRHSonly = FALSE, topOnly = FALSE, latentOnly = FALSE, endOnly = FALSE) { - nimbleModel::getNodes(modelDef, stochOnly, determOnly, includeData, dataOnly, + nimbleModel::getNodes(modelDef, nodes, stochOnly, determOnly, includeData, dataOnly, includePredictive, predictiveOnly, includeRHSonly, topOnly, latentOnly, endOnly) }, @@ -49,6 +51,22 @@ modelBase_nClass <- nClass( logProb <- logProb + declFunList[[instrList[[i]]$declID]]$calculate(instrList[[i]]) } return(logProb) + }, + simulate = function(instrList) { + if(inherits(instrList, 'instr_nClass')) { + oneInstr <- instrList + instrList <- nList(instr_nClass)$new() + instrList$setLength(1) + instrList[[1]] <- oneInstr + } + if(!((inherits(instrList, 'nList') || is.list(instrList)) && inherits(instrList[[1]], 'instr_nClass'))) + instrList <- makeInstrList(self, instrList) + ## Assume instrList is ordered (it is done `makeInstrList`). + if(isCompiled()) + return(simulate_impl(instrList)) + for(i in 1:length(instrList)) { + declFunList[[instrList[[i]]$declID]]$simulate(instrList[[i]]) + } } ), Cpublic = list( @@ -68,11 +86,25 @@ modelBase_nClass <- nClass( returnType = 'numericScalar', compileInfo = list( C_fun = function(instrList = 'nList(instr_nClass)') { - ## TODO: consider whether instrList will be ordered and/or how C++ will see the decl indexing info. + ## NOTE: instrList input will be ordered. cppLiteral('modelClass_::calculate(instrList);') }, virtual=TRUE ) + ), + simulate_impl = nFunction( + name = "simulate_impl", + function(instrList) { + cat("Uncompiled `simulate_impl` should never be called.\n") + return(0) + }, + returnType = 'numericScalar', + compileInfo = list( + C_fun = function(instrList = 'nList(instr_nClass)') { + cppLiteral('modelClass_::simulate(instrList);') + }, + virtual=TRUE + ) ) ), ## See comment above about needing to ensure a virtual destructor diff --git a/nimbleModel/R/modelDef.R b/nimbleModel/R/modelDef.R index a41e155..24a082d 100644 --- a/nimbleModel/R/modelDef.R +++ b/nimbleModel/R/modelDef.R @@ -895,6 +895,10 @@ modelDefClass <- R6Class( ## Note: data-related flags not handled as that relates to flags on a model ## and not part of modelDef. +## TODO: these should presumably take the model not modelDef as the first arg. +## Once we integrate modelClass with modelBase_nClass, we should be able to +## pass `self` from the getDeps and getParents methods to these functions. + getDependencies <- function(modelDef, nodes, self = TRUE, downstream = FALSE, immediateOnly = FALSE) { diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index a8262a2..c453726 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -203,8 +203,8 @@ if(FALSE) { } ######## - ## CJP experimentation with nimbleModel, modelClass stuff. + library(nimbleModel);library(nCompiler) code <- quote({ @@ -234,6 +234,10 @@ m$calculate(instrList) m$calculate(c('y','sd')) # ordering should be done internally +m$y +m$simulate('y') +m$y + # cr <- m$modelDef$calcRules[['y']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['y']]$rules[[1]]$apply('y')) # cr <- m$modelDef$calcRules[['sd']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['sd']]$rules[[1]]$apply('sd')) @@ -249,6 +253,7 @@ m$calculate(c('y','sd')) m <- nimbleModel(code, data = data, inits = inits, returnClass = FALSE) m$calculate(m$getDependencies('sd')) +m$calculate(m$getDependencies('sd', self = FALSE)) ## Try out compilation; see nCompiler's test-nimbleModel.R. From 984094e6fcb16a2dec7e1866e35007577bd7c119 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 10:33:20 -0700 Subject: [PATCH 05/32] Move model-specific class init into modelBase_nClass. --- nimbleModel/R/modelBaseClass.R | 49 ++++++++++++++++++++++++++++++ nimbleModel/R/nimbleModel.R | 55 ++-------------------------------- 2 files changed, 51 insertions(+), 53 deletions(-) diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 58412d5..84c9101 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -7,6 +7,55 @@ modelBase_nClass <- nClass( nondataRules = NULL, predictiveRules = NULL, nonpredictiveRules = NULL, + initialize = function(sizes = list(), inits = list(), data = list()) { + # It is not very easy to set debug onto the initialize function, so + # here is a magic flag. + if(isTRUE(.GlobalEnv$.debugModelInit)) browser() + super$initialize() + + declFunNames <- names(self$declFunNameToIndex) + if(isCompiled()) { + self$setup_decl_mgmt_from_names(declFunNames) + } else { + self$declFunList <- list() + length(self$declFunList) <- length(declFunNames) + names(self$declFunList) <- declFunNames + for(declFunName in declFunNames) { + self[[declFunName]] <- eval(as.name(self$CpublicDeclFuns[[declFunName]]))$new() + self[[declFunName]]$setModel(self) + self$declFunList[[self$declFunNameToIndex[[declFunName]]]] <- self[[declFunName]] + } + } + + ## TODO: create a merge_and_set function that handles all three of the following. + allSizes <- self$defaultSizes + if(!missing(sizes)) + for(nm in names(sizes)) + allSizes[[nm]] <- sizes[[nm]] + ## TODO: should we handle 0-dim sizes elsewhere? + allSizes <- allSizes[sapply(allSizes, length) > 0] + if(length(allSizes)) resize_from_list(allSizes[sapply(allSizes, length) > 0]) + + allInits <- self$defaultInits + if(!missing(inits)) + for(nm in names(inits)) + allInits[[nm]] <- inits[[nm]] + if(length(allInits)) set_from_list(allInits) + + if(missing(inits)) { + allInits <- self$defaultInits + } else + if(length(inits)) set_from_list(inits) + + ## TODO: do we want to handle data differently? + ## TODO: need to work through not setting as 'data' if values are NA; + ## check back against how dataRules work in nimbleModel work. + allData <- self$defaultData + if(!missing(inits)) + for(nm in names(inits)) + allData[[nm]] <- inits[[nm]] + if(length(allData)) set_from_list(allData) + }, getVarNames = function(includeLogProb = FALSE, nodeRanges) { if(missing(nodeRanges)){ if(includeLogProb) return(modelDef$varNames) diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index b4b03b5..dc70c71 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -32,8 +32,6 @@ make_modelClass_from_nimbleModel <- function(m, compile=FALSE) { modelVarInfo <- get_varInfo_from_nimbleModel(m) declInfoList <- list() declFunClassList <- list() - # two vectors for canonical use for calculation instructions - # to move between names and indices of declFxns: declFunNames <- names(mDef$declFunNameToIndex) for(i in seq_along(mDef$declInfo)) { declInfo <- mDef$declInfo[[i]] @@ -132,6 +130,7 @@ make_declFun_nClass <- function(varInfo = list(), } # This was a prototype + # Actually, we are using this. Ok? // CJP declFun_nClass <- substitute( nClass( inherit = declFunBase_nClass, @@ -263,57 +262,7 @@ makeModel_nClass <- function(modelVarInfo, initializers = decl_pieces |> lapply(\(x) x$init_string) |> unlist()) ) ) |> structure(names = classname) - initialize <- function(sizes = list(), inits = list(), data = list()) { - # It is not very easy to set debug onto the initialize function, so - # here is a magic flag. - if(isTRUE(.GlobalEnv$.debugModelInit)) browser() - super$initialize() - ## TODO: figure out which of the following to the base class initialize. - ## For now just putting these here in one place. - declFunNames <- names(self$declFunNameToIndex) - if(isCompiled()) { - self$setup_decl_mgmt_from_names(declFunNames) - } else { - self$declFunList <- list() - length(self$declFunList) <- length(declFunNames) - names(self$declFunList) <- declFunNames - for(declFunName in declFunNames) { - self[[declFunName]] <- eval(as.name(self$CpublicDeclFuns[[declFunName]]))$new() - self[[declFunName]]$setModel(self) - self$declFunList[[self$declFunNameToIndex[[declFunName]]]] <- self[[declFunName]] - } - } - - ## TODO: create a merge_and_set function that handles all three of the following. - - allSizes <- self$defaultSizes - if(!missing(sizes)) - for(nm in names(sizes)) - allSizes[[nm]] <- sizes[[nm]] - ## TODO: should we handle 0-dim sizes elsewhere? - allSizes <- allSizes[sapply(allSizes, length) > 0] - if(length(allSizes)) resize_from_list(allSizes[sapply(allSizes, length) > 0]) - allInits <- self$defaultInits - if(!missing(inits)) - for(nm in names(inits)) - allInits[[nm]] <- inits[[nm]] - if(length(allInits)) set_from_list(allInits) - - if(missing(inits)) { - allInits <- self$defaultInits - } else - if(length(inits)) set_from_list(inits) - - # TODO: do we want to handle data differently? - # TODO: need to work through not setting as 'data' if values are NA; - # check back against how dataRules work in nimbleModel work. - allData <- self$defaultData - if(!missing(inits)) - for(nm in names(inits)) - allData[[nm]] <- inits[[nm]] - if(length(allData)) set_from_list(allData) - } baseclass <- paste0("modelClass_<", classname, ">") # CpublicDeclFuns has elements like "decl_1 = quote(declFxn_1())" # We provide it in Cpublic to declare C++ member variables with types. @@ -335,7 +284,7 @@ makeModel_nClass <- function(modelVarInfo, ), list(OPDEFS = opDefs, # A list of individual elements - RPUBLIC = list(initialize=initialize, + RPUBLIC = list( declFunNameToIndex = model$modelDef$declFunNameToIndex, defaultSizes = modelVarInfo$sizes, defaultInits = inits, From 8b5372a31b2a50aa7d676c614b5edcb4aec7bdc0 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 10:47:49 -0700 Subject: [PATCH 06/32] Remove stray nList experimentation code in test-nimbleModel.R. --- nimbleModel/tests/testthat/test-nimbleModel.R | 28 ------------------- 1 file changed, 28 deletions(-) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index c453726..d5d602e 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -259,33 +259,5 @@ m$calculate(m$getDependencies('sd', self = FALSE)) ## Try out compilation; see nCompiler's test-nimbleModel.R. -# How get nCompiler to know about base class not in nCompiler? -# tmp=nList(nimbleModel:::declFxnBase_nClass) -#Error in self$resolveSym(project_env, ...) : -# In resolveSym method for symbolTBD (, :::), could not resolve an nClass generator. - -## experimenting ((not working) with creating and populating nLists -rNL <- nList(numericVector) -cl <- nClass( - Cpublic =list( - x = 'rNL', - myfun = nFunction( - function(y = 'numericScalar') { - return(y*x[[2]]) - }, returnType = 'numericVector' - ), - pop = nFunction( - function(x1 = 'numericVector', x2='numericVector') { - length(x) <- 3 - - x[[1]] <- x1 # this is still `1` as index in C++ - x[[2]] <- x2 - }) - )) -ccl <- nCompile(cl, rNL=rNL) -obj <- ccl[[1]]$new() -obj$pop(rnorm(3),rnorm(5)) -obj$myfun(3) - From 096bbb3570cd6b80c5e5610b3dbcd15e7f11d0b3 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 12:37:25 -0700 Subject: [PATCH 07/32] Fix simulate returnType. --- nimbleModel/R/declFunBaseClass.R | 8 ++++---- nimbleModel/R/modelBaseClass.R | 2 -- nimbleModel/R/nimbleModel.R | 2 ++ nimbleModel/tests/testthat/test-nimbleModel.R | 5 ++--- 4 files changed, 8 insertions(+), 9 deletions(-) diff --git a/nimbleModel/R/declFunBaseClass.R b/nimbleModel/R/declFunBaseClass.R index e269dd0..e0710b7 100644 --- a/nimbleModel/R/declFunBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -58,10 +58,10 @@ declFunBase_nClass <- nClass( name = "simulate", fun = function(instr = 'instr_nClass') { ## TODO: how embed determination of vec and parallel cases here? - if(instr$type == 0) return(sim_0(instr)) - if(instr$type == 1) return(sim_1_seq(instr)) - if(instr$type == 2) return(sim_1_mat(instr)) - if(instr$type == 3) return(sim_1_matp(instr)) + if(instr$type == 0) sim_0(instr) + if(instr$type == 1) sim_1_seq(instr) + if(instr$type == 2) sim_1_mat(instr) + if(instr$type == 3) sim_1_matp(instr) }, compileInfo = list(virtual=TRUE) ), diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 84c9101..6783693 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -174,5 +174,3 @@ modelBase_nClass <- nClass( # nCompile(modelBase_nClass, control=list(generate_predefined=TRUE)) -## The two "addModelDollarSign" functions are borrowed directly from nimble. -## This should add model$ in front of any names that are not already part of a '$' expression diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index dc70c71..adfc725 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -51,6 +51,8 @@ make_modelClass_from_nimbleModel <- function(m, compile=FALSE) { model = m, classname = "my_model", env = environment()) } +## The two "addModelDollarSign" functions are borrowed directly from nimble. +## This should add model$ in front of any names that are not already part of a '$' expression nm_addModelDollarSign <- function(expr, exceptionNames = character(0)) { if(is.numeric(expr)) return(expr) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index d5d602e..4b98345 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -220,6 +220,8 @@ data <- list(y = rnorm(5)) nm <- modelClass$new(code, inits = inits, data = data) mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) +cmclass <- nCompile(mclass) + # .debugModelInit <- TRUE m <- mclass$new(inits=list(sd=5, x = rnorm(6))) @@ -258,6 +260,3 @@ m$calculate(m$getDependencies('sd', self = FALSE)) ## Try out compilation; see nCompiler's test-nimbleModel.R. - - - From e06fe278917dc2ab0bd4c77878f00610a3247285 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Thu, 28 May 2026 08:17:48 -0700 Subject: [PATCH 08/32] Add missing line of code in RHS var processing to fix issue 6. --- nimbleModel/R/modelDef.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/nimbleModel/R/modelDef.R b/nimbleModel/R/modelDef.R index ea3d231..28db07a 100644 --- a/nimbleModel/R/modelDef.R +++ b/nimbleModel/R/modelDef.R @@ -664,7 +664,8 @@ modelDefClass <- R6Class( } } } - for(iDI in seq_along(declInfo)) { # Do RHS after all LHS so that check for overlap only concerns LHS + for(iDI in seq_along(declInfo)) { # Do RHS after all LHS so that check for overlap only concerns LHS + decl <- declInfo[[iDI]] for(iRHR in seq_along(decl$rhsOriginalRules)) { rhsRule <- decl$rhsOriginalRules[[iRHR]] rhsVar <- rhsRule$varName From ad2663e755c349d728288ac215cf6ca3d0246338 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Thu, 28 May 2026 09:08:48 -0700 Subject: [PATCH 09/32] Fix issue 5 by removing unused indices in originalIndexingRuleClass initialize. --- nimbleModel/R/originalIndexingRules.R | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/nimbleModel/R/originalIndexingRules.R b/nimbleModel/R/originalIndexingRules.R index dfba406..01034df 100644 --- a/nimbleModel/R/originalIndexingRules.R +++ b/nimbleModel/R/originalIndexingRules.R @@ -16,12 +16,13 @@ originalIndexingRuleClass <- R6Class( constants = list()) { varName <<- getVarName(LHS) if(length(context$indexVarNames)) { - ## Exclude indices not used in lifted expression, e.g., `i` in `y[i,j] ~ dnorm(mu[i], sigma[j])` + ## Exclude indices not used in lifted expression, e.g., `i` in `y[i,j] ~ dnorm(mu[i], var = sigma2[j])` indexVarNames <- context$indexVarNames indexVarNames <- indexVarNames[indexVarNames %in% all.vars(LHS)] - dummyLHS <- parse(text = paste0(varName, "[", - paste(indexVarNames, collapse = ","), - "]"))[[1]] + indexing <- if(length(indexVarNames)) + paste0("[", paste(indexVarNames, collapse = ","), "]") else "" + dummyLHS <- parse(text = paste0(varName, indexing))[[1]] + ## Unused singleContexts will be removed in graphRuleClass$new(). } else dummyLHS <- as.name(varName) graphRule <<- graphRuleClass$new(dummyLHS, LHS, From 975961fe20d3da4bc98a31b84afa914d81d3f782 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Thu, 28 May 2026 11:02:01 -0700 Subject: [PATCH 10/32] Take some steps towards compilation of nimbleModels. --- nimbleModel/R/instructions.R | 4 +++- nimbleModel/R/modelBaseClass.R | 7 ++++--- nimbleModel/R/nimbleModel.R | 2 +- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index aaa2ba4..f1a51a0 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -134,7 +134,9 @@ instr_nClass <- nClass( type = 'integerScalar', sortID = 'integerVector', declID = 'integerScalar' - ), compileInfo = list(interface = "full", + ), + predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("instr_nClass")), + compileInfo = list(interface = "full", createFromR = FALSE, exportName = "instr_nClass_new", packageNames = c(uncompiled="instr_nClass_R", compiled="instr_nClass") diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 6783693..ecca61d 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -119,8 +119,9 @@ modelBase_nClass <- nClass( } ), Cpublic = list( - declFunList = 'RcppObject', # This won't actually be used in C++, but needs to be in Cpublic for accessibility. - declFunMapping = 'RcppList', # Not sure what type this should be for use in C++. + ## TODO: using 'RcppObject' was resulting in a symbolTBD error - probably nCompiler issue 186. + declFunList = 'numericScalar', # 'RcppObject', # This won't actually be used in C++, but needs to be in Cpublic for accessibility. + declFunNameToIndex = 'RcppList', # Not sure what type this should be for use in C++. ping = nFunction( name = "ping", function() {return(TRUE); returnType(logical())}, @@ -160,7 +161,7 @@ modelBase_nClass <- nClass( predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("modelBase_nC")), compileInfo=list(interface="full", createFromR = FALSE, - Hincludes = c('"declFunBase_nClass_c_.h"'), + Hincludes = c('"declFunBase_nClass_c_.h","instr_nClass_c_.h"'), needed_units = list("declFunBase_nClass","instr_nClass"), exportName = "modelBase_nClass_new", packageNames = c(uncompiled="modelBase_nClass_R", compiled="modelBase_nClass") diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index adfc725..fd962cc 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -415,7 +415,7 @@ make_decl_method_nFxn <- function(f, name, returnType='numericScalar') { name = name, fun = Rfun, argTypes = list(idx = 'integerVector'), - returnType = returnType, + returnType = T(returnType), compileInfo=list(C_fun=Cfun), ) nFxn From 3eb6148bd81c86c89e4864a900083d1d207778cf Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Tue, 19 May 2026 11:33:36 -0700 Subject: [PATCH 11/32] Add model and declFxn handling from PdV work in nCompiler and CJP sidework. --- nimbleModel/DESCRIPTION | 8 +- nimbleModel/NAMESPACE | 1 + nimbleModel/R/declFxnBaseClass.R | 69 +++ nimbleModel/R/instructions.R | 140 +++++ nimbleModel/R/model.R | 4 +- nimbleModel/R/modelBaseClass.R | 90 +++ nimbleModel/R/nimbleModel.R | 511 ++++++++++++++++++ nimbleModel/R/nodeRules.R | 69 +-- nimbleModel/tests/testthat/test-nimbleModel.R | 279 ++++++++++ 9 files changed, 1104 insertions(+), 67 deletions(-) create mode 100644 nimbleModel/R/declFxnBaseClass.R create mode 100644 nimbleModel/R/instructions.R create mode 100644 nimbleModel/R/modelBaseClass.R create mode 100644 nimbleModel/R/nimbleModel.R create mode 100644 nimbleModel/tests/testthat/test-nimbleModel.R diff --git a/nimbleModel/DESCRIPTION b/nimbleModel/DESCRIPTION index 0f1462c..693a2ba 100644 --- a/nimbleModel/DESCRIPTION +++ b/nimbleModel/DESCRIPTION @@ -3,9 +3,9 @@ Title: What the Package Does (one line, title case) Version: 0.0.0.9000 Authors@R: person("First", "Last", email = "first.last@example.com", role = c("aut", "cre")) Description: What the package does (one paragraph). -Depends: R (>= 3.3.3) +Depends: R (>= 4.1.0) Imports: - methods,R6 + methods,R6,nCompiler License: What license is it under? Encoding: UTF-8 LazyData: true @@ -43,6 +43,10 @@ Collate: varRange.R varRules.R varStore.R + declFxnBaseClass.R + modelBaseClass.R + instructions.R + nimbleModel.R diff --git a/nimbleModel/NAMESPACE b/nimbleModel/NAMESPACE index 9f9aabf..57a7f59 100644 --- a/nimbleModel/NAMESPACE +++ b/nimbleModel/NAMESPACE @@ -1,5 +1,6 @@ import(methods) import(R6) +import(nCompiler) ## Some exports are for testing convenience and may not need to be exported. ## Classes: R6 classes are exported as regular objects diff --git a/nimbleModel/R/declFxnBaseClass.R b/nimbleModel/R/declFxnBaseClass.R new file mode 100644 index 0000000..d35aa9c --- /dev/null +++ b/nimbleModel/R/declFxnBaseClass.R @@ -0,0 +1,69 @@ +#' @export +declFxnBase_nClass <- nClass( + classname = "declFxnBase_nClass", + Cpublic = list( + ## model = 'modelBase_nClass', + ping = nFunction( + name = "ping", + function() {return(TRUE); returnType(logical())}, + compileInfo = list(virtual=TRUE) + ), + calculate = nFunction( + name = "calculate", + fun = function(instr = 'instr_nClass') { + ## TODO: how embed determination of vec and parallel cases here? + if(instr$type == 0) return(calc_0(instr)) + if(instr$type == 1) return(calc_1_seq(instr)) + if(instr$type == 2) return(calc_1_mat(instr)) + if(instr$type == 3) return(calc_1_matp(instr)) + return(0) ## Need to error trap/warn if unhandled type requested + }, returnType = 'numericScalar', + compileInfo = list(virtual=TRUE) + ), + ## TODO: for all these type-specific calculates, how do we call the methods of the declFxn_nClass object? + calc_0 = nFunction( + name = 'calc_0', + function(instr = 'instr_nClass') { + ## Presumably this will have access to derive class' `calc_one`? + return(calc_one(0)) ## calc_one will always has `idx` as arg? + }, returnType = 'numericScalar' + ), + calc_1_seq = nFunction( + name = 'calc_1_seq', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + calc_one(instr$values[[1]][1]+i) + return(logProb) + }, returnType = 'numericScalar' + ), + calc_1_mat = nFunction( + name = 'calc_1_mat', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + calc_one(instr$values[[1]][i]) + return(logProb) + }, returnType = 'numericScalar' + ), + calc_1_matp = nFunction( + name = 'calc_1_mat', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + calc_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + return(logProb) + }, returnType = 'numericScalar' + ) + ), + ## We haven't dealt with ensuring a virtual destructor when any method is virtual + ## For now I did it manually by editing the .h and .cpp + predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> + file.path("declFxnBase_nC")), + compileInfo=list(interface="full", + createFromR = FALSE, + exportName = "declFxnBase_nClass_new", + needed_units = list("nodeInstr_nClass"), + packageNames = c(uncompiled="declFxnBase_nClass_R", compiled="declFxnBase_nClass") + ) +) diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R new file mode 100644 index 0000000..d48776b --- /dev/null +++ b/nimbleModel/R/instructions.R @@ -0,0 +1,140 @@ +type2itype <- list( + '0' = 0, + "1_seq" = 1, + "1_mat" = 2, + "1_matp" = 3, + "2_seq_seq" = 4, + "2_seq_mat" = 5, + "2_mat_seq" = 6, + "2_mat_mat" = 7, + "2_seq_matp" = 8, + "2_matp_seq" = 9, + "2_matp_matp" = 10, + "2_mat_matp" = 11, + "2_matp_mat" = 12, + "3_generic" = 13 # Need to deal with itype for _slot cases. +) + +## Stand-alone function for setting up inputs to instrClass constructor. +## This could be embedded in the constructor. +range2instr <- function(range) { + instr <- list() + if(!length(range$indexingRange$indexRanges)) { # No indexing + instr$lens <- 1 + instr$index_types <- 0 + instr$dim <- 0 + } else { + instr$lens <- sapply(range$indexingRange$indexRanges, function(x) x$numElements) + instr$dims <- sapply(range$indexingRange$rangeToIndexSlot, length) + instr$dim <- sum(instr$dims) + instr$slots <- unlist(range$indexingRange$rangeToIndexSlot) + instr$index_types <- sapply(range$indexingRange$indexRanges, function(x) + switch(class(x)[1], + "indexRangeScalarClass" = 2, + "indexRangeSequenceClass" = 1, + "indexRangeMatrixClass" = 2)) + instr$values <- lapply(range$indexingRange$indexRanges, function(x) + switch(class(x)[1], + "indexRangeScalarClass" = x$value, + "indexRangeSequenceClass" = x$start-1, # -1 to avoid constantly adding 1 in calculate() + "indexRangeMatrixClass" = c(t(matrix(x$values, nc = x$numColumns))))) # in calcRange, column major; need row major here for simpler/more efficient determination of indices + } + instr$type <- determineInstrType(instr) + instr$sortID <- range$sortID + instr$declID <- range$declID + return(instr) +} + +## Eventually think about reordering order of looping for efficiency (and take parallelization into account). +## For the moment, we determine mat vs. seq here and then in declClass calculate we will determine whether to +## vectorize based on whether possible based on the declaration. +## Open question of when to determine if to use parallel calculate. +determineInstrType <- function(instr, use_vec = FALSE) { + type <- NULL + if(!length(instr$dims)) + type <- "0" + if(length(instr$dims) == 1) + if(instr$index_types[1] == 1) { + type <- "1_seq" + } else { + if(instr$dims[1] == 1) type <- "1_mat" else type <- "1_matp" + } + if(length(instr$dims) == 2) + if(identical(instr$dims, c(1L,1L))) { + ## Some of these not yet written. + if(identical(instr$index_types, c(1,1))) + type <- "2_vec_vec" + if(identical(instr$index_types, c(1,2))) + if(instr$dims[2] == 1) type <- "2_seq_mat" else type <- "2_seq_matp" + if(identical(instr$index_types, c(2,1))) + if(instr$dims[1] == 1) type <- "2_mat_seq" else type <- "2_matp_seq" + if(identical(instr$index_types, c(2,2))) { + if(all(instr$dims == 1)) type <- "2_mat_mat" + if(all(instr$dims == 2)) type <- "2_matp_matp" + if(instr$dims[[1]] == 2) type <- "2_matp_mat" + if(instr$dims[[2]] == 2) type <- "2_mat_matp" + } + } else type <- "2_generic" + if(length(instr$dims) == 3) type <- "3_generic" + if(is.null(type)) stop("no available specific instruction type") + ## TODO: determine how much about slots will be pre-baked. + if(length(instr$dims) && !identical(instr$slots, 1:instr$dim)) # Non-canonical slot ordering + type <- paste(type, "slots", sep = "_") + return(type2itype[[type]]) +} + +makeInstrList <- function(model, varRanges, use_vec = FALSE) { + if(missing(varRanges)) + varRanges <- model$getVarNames() + ## This works with a char vector of "nodes" or a list of (or single) varRanges + if(is(varRanges, 'varRangeClass')) varRanges <- list(varRanges) + ## First apply calcRule to get overlap between input and the rule. + ## Then make the calcRange to convert to loop indexing. + ## Note that `calcRule$apply` handles converting char to varRange and handling full variable extent. + ranges <- unlist(lapply(varRanges, function(vr) + lapply(model$modelDef$calcRules[[nimbleModel:::getVarName(vr)]]$rules, function(rule) + rule$makeCalcRange(rule$apply(vr)) + ))) + instrList <- nList(instr_nClass)$new() + numRanges <- length(ranges) + instrList$setLength(numRanges) + for(i in 1:numRanges) + instrList[[i]] <- instr_nClass$new(ranges[[i]]) + return(instrList) +} + +instr_nClass <- nClass( + classname = "instr_nClass", + Rpublic = list( + initialize = function(calcRange) { + instrList <- range2instr(calcRange) # This processing could simply be included here in `initialize`. + self$lens <- instrList$lens + self$index_types <- instrList$index_types + self$dim <- instrList$dim + self$dims <- instrList$dims + self$slots <- instrList$slots + self$values <- nList(integerVector)$new() + self$values$setLength(length(self$dims)) + if(self$dim) + for(i in 1:length(self$dims)) + self$values[[i]] <- instrList$values[[i]] + self$type <- instrList$type # Use integer for compilation (would char be ok?). + self$sortID <- instrList$sortID + self$declID <- instrList$declID + }), + Cpublic = list( + lens = 'integerVector', + index_types = 'integerVector', + dim = 'integerScalar', + dims = 'integerVector', + slots = 'integerVector', + values = 'nList(integerVector)', + type = 'integerScalar', + sortID = 'integerVector', + declID = 'integerScalar' + ), compileInfo = list(interface = "full") # TODO: check on this. +) +## TODO: determine how to handle this in terms of it being a predefined nClass +## TODO: see PdV version and determine what `compileInfo` elements are needed. + + diff --git a/nimbleModel/R/model.R b/nimbleModel/R/model.R index 4ad3205..2dc0b64 100644 --- a/nimbleModel/R/model.R +++ b/nimbleModel/R/model.R @@ -42,7 +42,9 @@ modelClass <- R6Class( } } - + origInits <<- inits + origData <<- data + if(length(data) && sum(names(data) == "")) stop("modelClass: 'data' must be a named list") if(any(!sapply(data, function(x) { diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R new file mode 100644 index 0000000..90abf31 --- /dev/null +++ b/nimbleModel/R/modelBaseClass.R @@ -0,0 +1,90 @@ +#' @export +modelBase_nClass <- nClass( + classname = "modelBase_nClass", + Rpublic = list( + ## TODO: bring in methods and fields from nimbleModel:::modelClass. + modelDef = NULL, + dataRules = NULL, + nondataRules = NULL, + predictiveRules = NULL, + nonpredictiveRules = NULL, + getVarNames = function(includeLogProb = FALSE, nodeRanges) { + if(missing(nodeRanges)){ + if(includeLogProb) return(modelDef$varNames) + else return(names(modelDef$varInfo)) + } else { + if(!is.list(nodeRanges)) + nodeRanges <- list(nodeRanges) + return(unique(sapply(nodeRanges, `[[`, 'varName'))) + } + }, + getDependencies = function(nodes, self = TRUE, downstream = FALSE, immediateOnly = FALSE) { + nimbleModel:::getDependencies(modelDef, nodes, self, downstream, immediateOnly) + } + ), + Cpublic = list( + declList = 'nList(declFxnBase_nClass)', + ping = nFunction( + name = "ping", + function() {return(TRUE); returnType(logical())}, + compileInfo = list(virtual=TRUE) + ), + calculate = nFunction( + ## TODO: What is the difference between having this as Cpublic with separate C_fun and having in R_public? + name = "calculate", + function(instrList) { + cat("In uncompiled calculate\n") + if(inherits(instrList, 'instr_nClass')) + instrList <- list(instrList) + if(FALSE) { + ## TODO: self is a Cpub_uncompiled obj, not full specialized model class. + ## So this doesn't work as we need self$modelDef in `makeInstrList()`. + if(!(is.list(instrList) && inherits(instrList[[1]], 'instr_nClass'))) + instrList <- makeInstrList(self, instrList) + } + logProb <- 0 + ord <- order(unlist(lapply(instrList, function(x) x$sortID))) + ## This is where uncompiled stepping through the calcInstrList happens. + for(i in 1:length(ord)) { + ## TODO: need to sort out this lookup process. + ## nodeIdx <- instr$declID + ## nodemember_name <- self$nodeObjNames[nodeIdx] # nodeObjNames is found in the derived class + logProb <- logProb + declList[[instrList[[ord[i]]]$declID]]$calculate(instrList[[ord[i]]]) + } + return(logProb) + }, + returnType = 'numericScalar', + compileInfo = list( + C_fun = function(instrList='nList(instr_nClass)') { + logProb <- 0 + ## For now assuming instructions are in order. + for(i in 1:length(instrList)) { + ## nodemember_name <- self$nodeObjNames[instrList[[i]]$declID] + logProb <- logProb + declList[[instrList[[i]]$declID]]$calculate(instrList[[i]]) + } + return(logProb) + }, + virtual=TRUE + ) + ) + ), + ## See comment above about needing to ensure a virtual destructor + predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("modelBase_nC")), + compileInfo=list(interface="full", + createFromR = FALSE, + Hincludes = c('"declFxnBase_nClass_c_.h"'), #, '"calcInstrList_nClass_c_.h"'), # "declFxnBase_nClass_c_.h" needed for package = TRUE + needed_units = list("declFxnBase_nClass","instr_nClass"), + exportName = "modelBase_nClass_new", + packageNames = c(uncompiled="modelBase_nClass_R", compiled="modelBase_nClass") + ) +) + +# Manually add +# # "#include " to that file, +# after the header content. + + +# nCompile(modelBase_nClass, control=list(generate_predefined=TRUE)) + +## The two "addModelDollarSign" functions are borrowed directly from nimble. +## This should add model$ in front of any names that are not already part of a '$' expression diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R new file mode 100644 index 0000000..0221df6 --- /dev/null +++ b/nimbleModel/R/nimbleModel.R @@ -0,0 +1,511 @@ +## It's unclear what this should return since in nimble one gets a model object +## but with nCompiler, we need a modelClass to compile and then we can create an instance. +## If we create an instance as the output here, one can't then compile that with an algorithm via `nCompile`. +## Need to think more about the workflow for nimble 2.0. +nimbleModel <- function(code, + constants = list(), + data = list(), + inits = list(), + dimensions = list(), + compile = FALSE, + returnClass = TRUE, + where = globalenv(), + debug = FALSE, + check = getNimbleOption('checkModel'), + calculate = TRUE, + name = NULL, + buildDerivs = getNimbleOption('buildModelDerivs'), + userEnv = parent.frame()) { + ## TODO: arg list taken from `nimble`. Revisit which options are needed. + ## For the moment this goes through nimbleModel R6 class and then nCompiler class. Clean that up once ideas are in place. + ## Presumably everything would be in Rpublic initialize for modelBaseClass, so this function will just call modelBase_nClass$new(). + m <- modelClass$new(name = name, code = code, constants = constants, data = data, inits = inits, dimensions = dimensions, userEnv = userEnv) + modelClassInstance <- make_modelClass_from_nimbleModel(m) + if(compile) modelClassInstance <- nCompile(modelClassInstance) + if(returnClass) return(modelClassInstance) # Standard use for when compiling a model(class) and algo(class) together. + model <- modelClassInstance$new() # Otherwise return model object for manipulation from R. +} + +make_modelClass_from_nimbleModel <- function(m, compile=FALSE) { + mDef <- m$modelDef + allVarInfo <- get_varInfo_from_nimbleModel(m) + modelVarInfo <- allVarInfo$vars + declFxnNames <- character() + declInfoList <- list() + declFxnList <- list() + # two vectors for canonical use for calculation instructions + # to move between names and indices of declFxns: + for(i in seq_along(mDef$declInfo)) { + declInfo <- mDef$declInfo[[i]] + decl_methods <- make_decl_methods_from_declInfo(declInfo) + declVars <- decl_methods |> lapply(\(x) all.vars(body(x))) |> unlist() |> unique() |> setdiff(c("idx", "LocalNewLogProb_", "LocalAns_", "model")) %||% character() + declVarInfo <- modelVarInfo[declVars] + SLN <- declInfo$sourceLineNumber + decl_classname <- paste0("declClass_", SLN) # name of an nClass generator + decl_RvarName <- paste0("declFxn_", SLN) # name of an R variable holding the nClass generator + decl_membername <- paste0("decl_", SLN) # name of model member variable holding an instance of the nClass + # Currently, we can't just make a list of these but need them as named objects in the environment + declFxnList[[decl_RvarName]] <- make_declFxn_nClass(declVarInfo, decl_methods, decl_classname) + assign(decl_RvarName, + declFxnList[[decl_RvarName]] + ) + declInfoList[[i]] <- make_decl_info_for_model_nClass(decl_membername, decl_RvarName, decl_classname, declVarInfo) + } + modelClassInstance <- makeModel_nClass(modelVarInfo, declInfoList, inits = m$origInits, data = m$origData, model = m, classname = "my_model", env = environment()) +} + + +nm_addModelDollarSign <- function(expr, exceptionNames = character(0)) { + if(is.numeric(expr)) return(expr) + if(is(expr, 'srcref')) return(expr) + if(is.name(expr)) { + if((as.character(expr) %in% exceptionNames) || (as.character(expr) == '')) return(expr) + proto <- quote(model$a) + proto[[3]] <- expr + return(proto) + } + if(is.call(expr)) { + if(expr[[1]] == '$'){ + expr[2] <- lapply(expr[2], function(listElement) nm_addModelDollarSign(listElement, exceptionNames)) + return(expr) + } + if(expr[[1]] == 'returnType') + return(expr) + if(length(expr) > 1) { + expr[2:length(expr)] <- lapply(expr[-1], function(listElement) nm_addModelDollarSign(listElement, exceptionNames)) + return(expr) + } + } + return(expr) +} + +# Turn variables and methods into a declFxn nClass +make_declFxn_nClass <- function(varInfo = list(), + methods = list(), + classname) { + # varInfo will be a list (names not used) of name, nDim, sizes. + # These are the model member variables to be used by the declFxn. + # They will be used in a constructor to set up C++ references to model variables. + CpublicVars <- varInfo |> lapply(\(x) paste0("ref(double(", x$nDim ,", interface=FALSE))")) + names(CpublicVars) <- varInfo |> lapply(\(x) x$name) |> unlist() + + +# varInfo_2_symbol <- \(x) nCompiler:::symbolBasic$new( +# type="double", nDim=x$nDim, name="", isRef=TRUE, isConst=FALSE, interface=FALSE) # In future maybe isConst=TRUE, but it might not matter much +# symbolList <- varInfo |> lapply(varInfo_2_symbol) +# names(symbolList) <- varInfo |> lapply(\(x) x$name) |> unlist() + numVars <- length(varInfo) + +# CpublicVars <- names(symbolList) |> lapply(\(x) eval(substitute(quote(T(symbolList$NAME)), +# list(NAME=as.name(x))))) +# names(CpublicVars) <- names(symbolList) + # This is a kluge to have a model field in the Cpublic_obj, + # needed for uncompiled purposes, and for compiled purposes + # we instead use references to model variables. So + # the declared type here is arbitrary. + initFun <- function(){} + + if(numVars > 0) { + # ctorArgNames <- paste0(names(symbolList), '_') + ctorArgNames <- paste0(names(CpublicVars), '_') + # List used when generating C++ constructor code to allow direct initializers, necessary for references. + # initializersList <- paste0(names(symbolList), '(', ctorArgNames ,')') + initializersList <- paste0(names(CpublicVars), '(', ctorArgNames ,')') + formals(initFun) <- structure(as.pairlist(CpublicVars), names = ctorArgNames) + } else { + initializersList <- character() + } + if(missing(classname)) + classname <- declFxnLabelCreator() + + baseclass <- paste0("declFxnClass_<", classname, ">") + + # Rpublic method to set the model pointer/reference. + setModel <- function(model) { + if(!isCompiled()) { + self$model <- model + #private$Cpublic_obj$model <- model + } + else + warning("setModel called on compiled object; no action taken") + } + +# This was a prototype + declFxn_nClass <- substitute( + nClass( + inherit = declFxnBase_nClass, + classname = CLASSNAME, + Rpublic = RPUBLIC, + Cpublic = CPUBLIC, + compileInfo = list( + createFromR = FALSE, # Without a default constructor (which we've disabled here), createFromR is impossible + nClass_inherit = list(base = BASECLASS)) # Ideally this line would be obtained from a base nClass, but we insert it directly for now + ), + list( + CPUBLIC = c( + list( + nFunction( + initFun, + compileInfo = list(constructor=TRUE, initializers = initializersList) + ) + ) |> structure(names = classname), + CpublicVars, + list(model = "RcppList"), + methods + ), + RPUBLIC = list(#model = NULL, + setModel = setModel), + CLASSNAME = classname, + BASECLASS = baseclass + )) + eval(declFxn_nClass) +} +#test <- nCompiler:::type2symbol('CppVar(baseType = type2cpp("numericVector"), ref=TRUE, const=TRUE)') + +# Make all the info needed to include a decl in a model class. +# The declFxn_nClass should be created first. +# Currently it needs to have a name to include in nCompile(). Later we might be able to pass the object itself +# At first drafting this is fairly trivial but could grow in complexity. + +make_decl_info_for_model_nClass <- function(membername, + declFxnName, + classname, + varInfo = list() + ) { + ctorArgs <- varInfo |> lapply(\(x) x$name) |> unlist() + + list(declFxnName = declFxnName, + membername = membername, + classname = classname, + ctorArgs = ctorArgs) +} + +makeModel_nClass <- function(varInfo, + decls = list(), + classname, + sizes = list(), + inits = list(), + data = list(), + model = NULL, + env = parent.frame() + ) { + # varInfo will be a list (names not used) of name, nDim, sizes. + CpublicModelVars <- varInfo |> lapply(\(x) paste0("numericArray(nDim=",x$nDim,")")) + names(CpublicModelVars) <- varInfo |> lapply(\(x) x$name) |> unlist() + opDefs <- list( + base_ping = nCompiler:::getOperatorDef("custom_call"), + setup_decl_mgmt = nCompiler:::getOperatorDef("custom_call"), + do_setup_decl_mgmt_from_names = nCompiler:::getOperatorDef("custom_call") + ) + opDefs$base_ping$returnType <- nCompiler:::type2symbol(quote(void())) # How can this be passed into nClass? + opDefs$base_ping$labelAbstractTypes$recurse <- FALSE + opDefs$setup_decl_mgmt$returnType <- nCompiler:::type2symbol(quote(void())) + opDefs$setup_decl_mgmt$labelAbstractTypes$recurse <- FALSE + opDefs$do_setup_decl_mgmt_from_names$returnType <- nCompiler:::type2symbol(quote(void())) + opDefs$do_setup_decl_mgmt_from_names$labelAbstractTypes$recurse <- FALSE + + if(missing(classname)) + classname <- modelLabelCreator() + + CpublicMethods <- list( + do_setup_decl_mgmt = nFunction( + name = "call_setup_decl_mgmt", + function() {}, + compileInfo=list( + C_fun = function() {setup_decl_mgmt()}) + ), + setup_decl_mgmt_from_names = nFunction( + name = "call_setup_decl_mgmt_from_names", + function(declNames) {}, + compileInfo=list( + C_fun = function(declNames="RcppCharacterVector") {do_setup_decl_mgmt_from_names(declNames)}) + ), + print_decls = nFunction( + name = "print_decls", + function() {}, + compileInfo=list( + C_fun = function() {cppLiteral('modelClass_::c_print_decls();')}) + ), + set_from_list = nFunction( + name = "set_from_list", + function(Rlist) {for(v in names(Rlist)) + if(exists(v, self, inherits=FALSE)) self[[v]] <- Rlist[[v]]}, + compileInfo=list( + C_fun=function(Rlist = 'RcppList') {cppLiteral('modelClass_::set_from_list(Rlist);')}) + ), + resize_from_list = nFunction( + name = "resize_from_list", + function(Rlist) {for(v in names(Rlist)) + if(exists(v, self, inherits=FALSE)) self[[v]] <- nArray(dim=Rlist[[v]])}, + compileInfo = list( + C_fun=function(Rlist = 'RcppList') {cppLiteral('modelClass_::resize_from_list(Rlist);')}) + ) + ) + # decls will be a list of membername, declFxnName, (decl) classname, ctorArgs (list) + decl_pieces <- decls |> lapply(\(x) { + #nClass_type <- paste0(x$declFxnName, "()") + init_string <- paste0('nCpp("', x$membername, '( new ', x$classname, '(', + paste0(x$ctorArgs, collapse=","), '))")') + list(nClass_type = x$declFxnName, + init_string = init_string, + membername = x$membername) + }) + declObjNames <- (decl_pieces |> lapply(\(x) x$membername) |> unlist()) %||% character() + # declObjNames also serves for canonical lookup of names by index. + # e.g. declObjNames[i] gives the member name of the index=i decl member. + declObjName_2_declIndex <- seq_along(declObjNames) |> structure(names=declObjNames) + # Inversely, declobjName_2_declIndex["decl_3"] gives the index of that decl. + CpublicDeclFuns <- decl_pieces |> lapply(\(x) x$nClass_type) |> setNames(declObjNames) + # CpublicDeclFuns <- list( + # beta_decl = 'decl_dnorm()' + # ) + CpublicCtor <- list( + nFunction( + function(){}, + compileInfo = list(constructor=TRUE, + #initializers = c('nCpp("beta_decl(new decl_dnorm(mu, beta, 1))")')) + initializers = decl_pieces |> lapply(\(x) x$init_string) |> unlist()) + ) + ) |> structure(names = classname) + initialize <- function(sizes = list(), inits = list(), data = list()) { + # It is not very easy to set debug onto the initialize function, so + # here is a magic flag. + if(isTRUE(.GlobalEnv$.debugModelInit)) browser() + super$initialize() + if(isCompiled()) + self$setup_decl_mgmt_from_names(self$declObjNames) + if(!isCompiled()) { + for(declObj in self$declObjNames) { + self[[declObj]] <- eval(as.name(self$CpublicDeclFuns[[declObj]]))$new() + self[[declObj]]$setModel(self) + } + } + + # First expand any provided or default sizes + # To-Do possibly merge the argument sizes and defaultSizes by element. + if(missing(sizes)) sizes <- self$defaultSizes + if(length(sizes)) resize_from_list(sizes) + + # Then any provided inits over-ride any provided sizes + # To-Do: Ditto + if(missing(inits)) inits <- self$defaultInits + if(length(inits)) set_from_list(inits) + + # TODO: do we want to handle data differently? + # TODO: need to work through not setting as 'data' if values are NA; + # check back against how dataRules work in nimbleModel work. + if(missing(data)) data <- self$defaultData + if(length(data)) set_from_list(data) +browser() + + + } + baseclass <- paste0("modelClass_<", classname, ">") + # CpublicDeclFuns has elements like "decl_1 = quote(declFxn_1())" + # We provide it in Cpublic to declare C++ member variables with types. + # We also place the list itself in the class so that we can look up for uncompiled execution + # the objects that need to be created in initialize. + # If we someday make type declarations and initializations more automatic, we can avoid this duplication. + ans <- substitute( + nClass( + classname = CLASSNAME, + inherit = modelBase_nClass, + compileInfo = list(opDefs = OPDEFS, + nClass_inherit = list(base=BASECLASS)#, +# needed_units = list("declFxnBase_nClass"), # needed for package=TRUE +# Hincludes = '"declFxnBase_nClass_c_.h"' # needed for package=TRUE + ), + Rpublic = RPUBLIC, + Cpublic = CPUBLIC, + env = env + ), + list(OPDEFS = opDefs, + # A list of individual elements + RPUBLIC = list(initialize=initialize, + declObjNames = declObjNames, + declObjName_2_declIndex = declObjName_2_declIndex, + defaultSizes = sizes, + defaultInits = inits, + defaultData = data, + modelDef = model$modelDef, + ## TODO: add other fields from `nimbleModel::modelClass` such as dataRules, predictiveRules, etc. + CpublicDeclFuns = CpublicDeclFuns), + # A concatenation of lists + CPUBLIC = c(CpublicDeclFuns, CpublicModelVars, CpublicCtor, CpublicMethods), + CLASSNAME = classname, + BASECLASS = baseclass) + ) + eval(ans) +} + +## Get varInfo from new nimbleModel +get_varInfo_from_nimbleModel <- function(model) { + mDef <- model$modelDef + extract <- \(x) x |> lapply(\(x) list(name = x$varName, nDim = x$nDim)) + vars <- mDef$varInfo |> extract() + logProbVars <- mDef$logProbVarInfo |> extract() + # The resize_from_list method will error out if a scalar is included. + # The maxs is empty for scalars, so they are automatically omitted from the sizes result here. + extract_sizes <- \(x) x|> lapply(\(x) x$maxs) + sizes <- mDef$varInfo |> extract_sizes() + logProb_sizes <- mDef$logProbVarInfo |> extract_sizes() + list( + vars = c(vars, logProbVars), + sizes = c(sizes, logProb_sizes) + ) +} + +# make_stoch_calculate <- function(LHSrep, RHSrep, logProbExprRep) { +# lenRHS <- length(RHSrep) +# if(length(RHS) > 1) { +# RHSrep[3:(lenRHS+1)] <- RHSrep[2:lenRHS] +# names(RHSrep)[3:(lenRHS+1)] <- names(RHSrep)[2:lenRHS] +# } +# RHSrep[[2]] <- LHSrep +# names(RHSrep)[2] <- "" +# RHSrep[[lenRHS+2]] <- 1 +# names(RHSrep)[lenRHS+2] <- "log" +# # We create separate code for R and C execution. +# calc1Cfun <- substitute( +# function(idx) {LHS <- RHS; return(LHS)}, +# list(LHS = logProbExprRep, RHS = RHSrep) +# ) |> eval() +# make_calculate_from_Cfun(calc1Cfun) +# } + +make_stoch_sim_line <- function(LHSrep, RHSrep) { + BUGSdistName <- nCompiler:::safeDeparse(RHSrep[[1]]) + distInfo <- getDistributionInfo(BUGSdistName) + sim_code <- as.name(distInfo$simulateName) + if(is.null(sim_code)) stop("Could not find simulation ('r') function for ", BUGSdistName) + RHSrep[[1]] <- sim_code + # scoot all named arguments right 1 position + if(length(RHSrep) > 1) { + for(i in (length(RHSrep)+1):3) { + RHSrep[i] <- RHSrep[i-1] + names(RHSrep)[i] <- names(RHSrep)[i-1] + } + } + RHSrep[[2]] <- 1 + names(RHSrep)[2] <- '' + sim_line <- substitute( + LHS <- RHS, + list(LHS = LHSrep, RHS = RHSrep)) + sim_line +} + +make_stoch_calc_line <- function(LHSrep, RHSrep, logProbExprRep, diff = FALSE) { + lenRHS <- length(RHSrep) + if(length(RHSrep) > 1) { + RHSrep[3:(lenRHS+1)] <- RHSrep[2:lenRHS] + names(RHSrep)[3:(lenRHS+1)] <- names(RHSrep)[2:lenRHS] + } + RHSrep[[2]] <- LHSrep + names(RHSrep)[2] <- "" + RHSrep[[lenRHS+2]] <- 1 + names(RHSrep)[lenRHS+2] <- "log" + # We create separate code for R and C execution. + if(!diff) { + calc_line <- substitute( + LHS <- RHS, + list(LHS = logProbExprRep, RHS = RHSrep)) + } else { + calc_line <- substitute( + LocalNewLogProb_ <- RHS, + list(RHS = RHSrep)) + } + calc_line +} + +make_determ_calc_line <- function(LHSrep, RHSrep) { + calc_line <- substitute( + LHS <- RHS, + list(LHS = LHSrep, RHS = RHSrep)) + calc_line +} + +make_nFxn_from_Cfun <- function(Cfun) { + Rfun <- Cfun + body(calc1Rfun) <- nm_addModelDollarSign(body(Cfun), exceptionNames = c("idx")) + nFxn <- nFunction( + name = "calc_one", + fun = Rfun, + compileInfo=list(C_fun=Cfun), + argTypes = list(idx = 'integerVector'), + returnType = 'numericScalar') + #declVars <- all.vars(body(calc1Cfun)) |> setdiff("idx") + nFxn +} + +make_decl_method_nFxn <- function(f, name, returnType='numericScalar') { + Cfun <- f + Rfun <- f + body(Rfun) <- nm_addModelDollarSign(body(f), exceptionNames = c("idx", "LocalNewLogProb_", "LocalAns_")) + if(is.null(returnType)) returnType <- 'void' + nFxn <- nFunction( + name = name, + fun = Rfun, + argTypes = list(idx = 'integerVector'), + returnType = returnType, + compileInfo=list(C_fun=Cfun), + ) + nFxn +} + +make_decl_methods_from_declInfo <- function(declInfo) { + # pieces are adapted from Chris' code in nimbleModel and/or old nimble. + # + # This function creates a calc_one nFunction that calculates single index case. + # This will then be used by generic iterator over indices. + # Vectorized cases can be added in this basic framework later. + modelCode <- declInfo$calculateCode + LHS <- modelCode[[2]] + RHS <- modelCode[[3]] + type <- if(modelCode[[1]]=="~") "stoch" else "determ" # or use declInfo$stoch (logical) + context <- declInfo$declRule$context + replacements <- sapply(seq_along(context$singleContexts), + function(i) parse(text = paste0('idx[',i,']'))[[1]]) + names(replacements) <- context$indexVarNames + LHSrep <- eval(substitute(substitute(e, replacements), list(e = LHS))) + RHSrep <- eval(substitute(substitute(e, replacements), list(e = RHS))) + + if(type == 'determ') { + methodList <- eval(substitute( + list( + sim_one = (function(idx) {calc_one(idx)}) |> + make_decl_method_nFxn("sim_one", NULL), + calc_one = (function(idx) {DETERMCALC; return(invisible(0))}) |> + make_decl_method_nFxn("calc_one"), + calcDiff_one = (function(idx) {calc_one(idx);return(invisible(0))}) |> + make_decl_method_nFxn("calcDiff_one"), + getLogProb_one = (function(idx) {return(0)}) |> + make_decl_method_nFxn("getLogProb_one") + ), + list(DETERMCALC = make_determ_calc_line(LHSrep, RHSrep)) + )) + } + if(type == 'stoch') { + logProbExpr <- declInfo$genLogProbExpr() + logProbExprRep <- eval(substitute(substitute(e, replacements), list(e = logProbExpr))) + methodList <- eval(substitute( + list( + sim_one = (function(idx) { STOCHSIM }) |> + make_decl_method_nFxn("sim_one", NULL), + calc_one = (function(idx) { STOCHCALC; return(invisible(LOGPROB)) }) |> + make_decl_method_nFxn("calc_one"), + calcDiff_one = (function(idx) {STOCHCALC_DIFF; LocalAns_ <- LocalNewLogProb_ - LOGPROB; + LOGPROB <- LocalNewLogProb_; return(invisible(LocalAns_))}) |> + make_decl_method_nFxn("calcDiff_one"), + getLogProb_one = (function(idx) { return(LOGPROB) }) |> + make_decl_method_nFxn("getLogProb_one") + ), + list( LOGPROB = logProbExprRep, + STOCHSIM = make_stoch_sim_line(LHSrep, RHSrep), + STOCHCALC = make_stoch_calc_line(LHSrep, RHSrep, logProbExprRep), + STOCHCALC_DIFF = make_stoch_calc_line(LHSrep, RHSrep, logProbExprRep, diff=TRUE)) + )) + } + methodList +} + + diff --git a/nimbleModel/R/nodeRules.R b/nimbleModel/R/nodeRules.R index c062875..42652e3 100644 --- a/nimbleModel/R/nodeRules.R +++ b/nimbleModel/R/nodeRules.R @@ -127,6 +127,7 @@ declRuleClass <- R6Class( originalIndexingRule = NULL, # Determines original indexing (based on context). decl = NULL, # Full declInfo; nodeRuleClass$expr is just LHS. calculate = NULL, # Generic function for calculation. + ID = NULL, # Unique ID that will be the index of the declClass in C++ (TBD how this is baked in). ## TODO: remove this: test = rep(0, 10), ## test element used for testing calculation while modelDef doesn't have acccess to a model test2 = matrix(0, 3, 5), @@ -239,7 +240,7 @@ calcRuleClass <- R6Class( indexingRange <- declRule$originalIndexingRule$apply(inputRange) if(is.null(indexingRange)) return(NULL) - result <- calcRangeClass$new(varName, indexingRange, declRule$calculate, sortID, multiSortIDindex) + result <- calcRangeClass$new(varName, indexingRange, declRule$ID, sortID, multiSortIDindex) return(result) }, @@ -395,75 +396,15 @@ calcRangeClass <- R6Class( sortID = NULL, calcFun = NULL, multiSortIDindex = NULL, - initialize = function(varName, indexingRange, calcFun, sortID, multiSortIDindex) { + declID = NULL, + initialize = function(varName, indexingRange, declID, sortID, multiSortIDindex) { varName <<- varName indexingRange <<- indexingRange calcFun <<- calcFun ## note that calcFun itself is not vectorized sortID <<- sortID + declID <<- declID multiSortIDindex <<- multiSortIDindex - }, - - ## Generic calculate function that crosses the indexRanges in the indexingRange (a varRange) - ## and extracts the original indices to feed into calculate nodeFunction - ## that operates on set of scalar indices. - - ## Keep indexing internal to the indexRange to avoid complicated and possibly repetitive - ## calculation of internal indexing. - - ## Will need to figure out how this is going to get compiled. - ## This will rely on nCompiler indexing of eigen tensors for static block indexes, e.g. '3:5' in x[i, 3:5] - ## which will presumably use the information in the symbolicParentNodes. - - calculate = function() { - numRanges <- length(indexingRange$indexRanges) - if(!numRanges) { # no indexing - result <- calcFun(NULL) - } else { - indexRange_lengths <- sapply(indexingRange$indexRanges, - function(x) x$numElements) - indexPositions <- indexingRange$rangeToIndexSlot - len <- prod(indexRange_lengths) - - ## TODO: This is a placeholder so we can test numerical results - ## once fuller workflow is in place, remove this and assignment of output of calcFun() - result <- rep(0, len) - - ## Set up information so `getNext` repeats index values for outer loop indices. - delay <- 1 - for(irIndex in rev(seq_len(numRanges))) { # work from inner-most loop outwards - indexingRange$indexRanges[[irIndex]]$setDelay(delay) - delay <- delay * indexingRange$indexRanges[[irIndex]]$numElements - } - - if(length(sortID) == 1 || len == 1) { - index <- numeric(length(indexingRange$indexSlotToRange)) ## vector to hold the original index values - for(item in seq_len(len)) { - for(irIndex in seq_len(numRanges)) - index[indexPositions[[irIndex]]] <- indexingRange$indexRanges[[irIndex]]$getNext() - result[item] <- calcFun(index) ## scalar calculation - } - } else { - index <- matrix(0, len, length(indexingRange$indexSlotToRange)) ## vector to hold the original index values - sortIDvals <- rep(0, len) - for(item in seq_len(len)) { - for(irIndex in seq_len(numRanges)) { - index[item, indexPositions[[irIndex]]] <- indexingRange$indexRanges[[irIndex]]$getNext() - } - sortIDvals[item] <- sortID[index[item, multiSortIDindex]] - } - for(item in order(sortIDvals)) - result[item] <- calcFun(index[item, ]) - } - } - ## Note that result will be vectorized based on the loop ordering so in simple rectangular - ## settings such as `y[i,j]` with `i` the outer index, it will be row-major. - return(result) - } - - ## simulate() should be very similar to calculate() - ## need to think more about getParam, getBound, etc., but probably also very similar, - ## just swapping out calcFun() for appropriate function. ) ) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R new file mode 100644 index 0000000..d6906c2 --- /dev/null +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -0,0 +1,279 @@ +# Test code needed for new nimbleModel system. + +library(nimbleModel) +library(testthat) + +## TODO: will location and access to predefined nClasses be as described below given they will live +## in `nimbleModel` package? How will dependence on nCompiler work? + +## TODO: before I generate the predefined code, need to check on what needs to be done in terms of +## compileInfo for modelBaseClass and declFxnBaseClass. + +## # To update the set of predefined nClasses +## # generate new predef/instr_nC. Move that directly to package code inst/nimbleModel/predef/nodeInstr_nC +## nCompile(instr_nClass, control=list(generate_predefined=TRUE)) +## test <- nCompile(instr_nClass) +## # +## # generate new predef/nodeFxnBase_nC. Move to package and add +## # "#include " in the hContent +## # after declaration of newFxnBase_nClass +## nCompile(nodeFxnBase_nClass, control=list(generate_predefined=TRUE)) +## test <- nCompile(nodeFxnBase_nClass) +## # +## # generate new predef/modelBase_nC. Move to package and add +## # "#include " to that file, +## # after the declaration of modelBase_nClass. +## nCompile(modelBase_nClass, control=list(generate_predefined=TRUE)) +## test <- nCompile(modelBase_nClass) +## #nCompile(nodeFxnBase_nClass, nodeInstr_nClass, control=list(generate_predefined=TRUE)) +## #nCompile(nodeInstr_nClass, calcInstr_nClass, modelBase_nClass, nodeFxnBase_nClass, calcInstrList_nClass, control=list(generate_predefined=TRUE)) + +## TODO: revise these tests for instrClass (flattened approach) + +test_that("nimble model prototype works", { + nodeVarInfo <- list(list(name = "x", nDim = 1), list(name = "mu", nDim = 1), + list(name = "sd", nDim = 0)) + calc_one <- nFunction( + name = "calc_one", + fun = function(inds) { + ans <- model$x[inds[1]] + return(ans) + }, + compileInfo = list( + C_fun = function(inds = 'integerVector') { + returnType('numericScalar') + ans <- x[inds[1]] + return(ans) + } + ) + ) + my_nodeFxn <- make_node_nClass(nodeVarInfo, list(calc_one=calc_one), "test_node") + my_nodeInfo <- make_node_info_for_model_nClass("beta_NF1", "my_nodeFxn", "test_node", nodeVarInfo) + + modelVarInfo <- list(list(name="x", nDim = 1), + list(name = "mu", nDim = 1), + list(name = "sd", nDim = 0), + list(name = "gamma", nDim = 2)) + #debug(makeModel_nClass) + ncm1 <- makeModel_nClass(modelVarInfo, list(my_nodeInfo), classname = "my_model", env=environment()) + #undebug(addGenericInterface_impl) + #undebug(nCompile_finish_nonpackage) + for(package in c(FALSE, TRUE)) { + Cncm1 <- nCompile(ncm1, returnList=TRUE, package=package) + #Cncm1 <- nCompile(modelBase_nClass, nodeFxnBase_nClass, calcInstrList_nClass, calcInstr_nClass, nodeInstr_nClass, ncm1, my_nodeFxn) + for(mode in c("uncompiled", "compiled")) { + if(mode=="compiled") { + obj <- Cncm1$ncm1$new() + } else { + obj <- ncm1$new() + } + # obj$do_setup_node_mgmt() + nodeObj <- obj$beta_NF1 + obj$x <- 1:3 + expect_equal(obj$x, 1:3) + + obj$set_from_list(list(x = 10:11)) + # expect Problem msg: (alpha is not a field in the class) + obj$set_from_list(list(mu = 110, x = 11:20, alpha = 101)) + obj$mu + + obj$resize_from_list(list(x = 7)) + # expect Problem msg: + obj$resize_from_list(list(alpha = 5, mu = 3, gamma = c(2, 4))) + expect_equal(length(obj$mu), 3) + expect_equal(dim(obj$gamma), c(2, 4)) + obj$resize_from_list(list(x = 5, gamma = c(3, 5))) + expect_equal(length(obj$x), 5) + expect_equal(dim(obj$gamma), c(3, 5)) + + obj$x <- 11:15 + expect_equal(nodeObj$calc_one(c(3)), 13) + rm(obj, nodeObj); gc() + } + } +}) + +test_that("nodeInstr_nClass and calcInstr_nClass basics work", { + for(package in c(FALSE, TRUE)) { + test <- nCompile(nodeInstr_nClass, calcInstr_nClass, calcInstrList_nClass, control=list(generate_predefined=FALSE), package = package) + calcInstrList <- test$nList_calcInstr_nClass$new() + calcInstr <- test$calcInstr_nClass$new() + expect_equal(calcInstr$nodeInstrVec, NULL) + ni1 <- test$nodeInstr_nClass$new() + ni2 <- test$nodeInstr_nClass$new() + ni1$methodInstr <- 1 + ni2$methodInstr <- 2 +# nList("integerVector")$new() +# ni1$indsInstrVec <- nList("integerVector")$new() + ni1$indsInstrVec[1:2] <- list(1:2, 3:4) + ni2$indsInstrVec + ni2$indsInstrVec[1:2] <- list(11:12, 13:14) + calcInstr$nodeInstrVec + calcInstr$nodeInstrVec[1:2] <- list(ni1, ni2) + + expect_true(length(calcInstr$nodeInstrVec)==2) + expect_identical(calcInstr$nodeInstrVec[[1]]$indsInstrVec |> as.list(), list(1:2, 3:4)) + expect_identical(calcInstr$nodeInstrVec[[2]]$indsInstrVec |> as.list(), list(11:12, 13:14)) + calcInstrList[1] <- list(calcInstr) + expect_equal(calcInstrList |> as.list(), list(calcInstr)) + rm(calcInstrList, calcInstr, ni1, ni2); gc() + } +}) + +###### + +## This is somewhat redundant with the first test +test_that("nimble model variables are set up", { + library(nimbleModel) + code <- quote({ + sd ~ dunif(0, 10) + for(i in 1:5) { + y[i] ~ dnorm(x[i+1], sd = sd) + } + }) + m <- modelClass$new(code) + varInfo <- get_varInfo_from_nimbleModel(m) + modelVars <- varInfo$vars + # Try making a model with no nodeFxns + ncm1 <- makeModel_nClass(modelVars, list(), classname = "my_model", env = environment()) + Cncm1 <- nCompile(ncm1, returnList=TRUE) + #Cncm1 <- nCompile(modelBase_nClass, nodeFxnBase_nClass, calcInstrList_nClass, calcInstr_nClass, nodeInstr_nClass, ncm1) + obj <- Cncm1$ncm1$new() + obj$resize_from_list(varInfo$sizes) + expect_equal(length(obj$x), 6) + expect_equal(length(obj$y), 5) + expect_equal(length(obj$logProb_y), 5) +}) + +######## +# nOptions(pause_after_writing_files=TRUE) +# Try automating the whole model creation including nodeFxns +# Ditto: this works but relies on nimbleModel +test_that("nimble model with stochastic and deterministic nodes is created and compiles", { + library(nimbleModel) + code <- quote({ + sd ~ dunif(0, 10) + for(i in 1:5) { + z[i] <- x[i+1] + 10 + y[i] ~ dnorm(x[i+1], sd = sd) + } + }) + m <- modelClass$new(code) + + ## Check that a separate R implementation was created + mDef_ <- m$modelDef + dI <- mDef_$declInfo[[2]] + nFxn <- make_node_methods_from_declInfo(dI) + expect_true(!is.null(NFinternals(nFxn[[1]])$R_fun)) + dI <- mDef_$declInfo[[3]] + nFxn <- make_node_methods_from_declInfo(dI) + expect_true(!is.null(NFinternals(nFxn[[1]])$R_fun)) + + for(mode in c("uncompiled", "compiled")) { + package_options <- if(mode=="compiled") c(FALSE, TRUE) else TRUE + for(package in package_options) { + nMod <- make_model_from_nimbleModel(m, compile=FALSE) + if(mode=="compiled") { + expect_no_error(CnMod <- nCompile(nMod, package = package)) + nMod <- CnMod + } + expect_no_error(obj <- nMod$new()) + obj$y <- 1:5 + expect_equal(obj$y, 1:5) + vals <- list(x = 2:7, y = 11:15, sd = 8) + obj$set_from_list(vals) + expect_equal(obj$x, vals$x) + rm(obj); gc() + } + } +}) + +message("test-nimbleModel does not have tests of calculate etc.") + +if(FALSE) { + nodeFxn_2_nodeIndex <- c(nodeFxn_1 = 1, nodeFxn_3 = 2) + + calcInputList <- list(list(nodeFxn="nodeFxn_1", # which declaration (nodeFxn) + nodeInputVec = list(list(methodInput=1, # which index iteration method + indsInputVec=list(1))))) # input(s) to index iterations + + calcInstrList <- calcInputList_to_calcInstrList(calcInputList, test) + + obj$calculate(calcInstrList) +} +######## + + +## CJP experimentation with nimbleModel, modelClass stuff. +library(nimbleModel);library(nCompiler) + +# source('modelBaseClass.R') +# source('declFxnBaseClass.R') +# source('nimbleModel.R') +# source('instructions.R') + +code <- quote({ + sd ~ dunif(0, 10) + for(i in 1:5) { + z[i] <- x[i+1] + 10 + y[i] ~ dnorm(x[i+1], sd = sd) + } +}) +inits <- list(sd = 1.5) +data <- list(y = rnorm(5)) +nm <- modelClass$new(code, inits = inits, data = data) +mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) +m <- mclass$new(inits=list(sd=5)) + +## m$calculate('sd') # Doesn't work because Cpublic calculate can't run makeInstrList as it can't access modelDef. + +instrList <- nimbleModel:::makeInstrList(m, 'sd') +m$calculate(instrList) +instrList <- nimbleModel:::makeInstrList(m, 'y') +m$calculate(instrList) + +# cr <- m$modelDef$calcRules[['y']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['y']]$rules[[1]]$apply('y')) +# cr <- m$modelDef$calcRules[['sd']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['sd']]$rules[[1]]$apply('sd')) + +## Direct access to decl calculation works. +out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calc_one(0) +out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calc_0(instrList[[1]]) +out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calculate(instrList[[1]]) + +# how initialize a list of declFxns? + +# How get nCompiler to know about base class not in nCompiler? +# tmp=nList(nimbleModel:::declFxnBase_nClass) +#Error in self$resolveSym(project_env, ...) : +# In resolveSym method for symbolTBD (, :::), could not resolve an nClass generator. + +## experimenting ((not working) with creating and populating nLists +rNL <- nList(numericVector) +cl <- nClass( + Cpublic =list( + x = 'rNL', + myfun = nFunction( + function(y = 'numericScalar') { + return(y*x[[2]]) + }, returnType = 'numericVector' + ), + pop = nFunction( + function(x1 = 'numericVector', x2='numericVector') { + length(x) <- 3 + + x[[1]] <- x1 # this is still `1` as index in C++ + x[[2]] <- x2 + }) + )) +ccl <- nCompile(cl, rNL=rNL) +obj <- ccl[[1]]$new() +obj$pop(rnorm(3),rnorm(5)) +obj$myfun(3) + + +## full workflow with getDeps + +## work on sortID + + + From 72ffd187fa76e652535028028f7fd2174016948d Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 09:02:48 -0700 Subject: [PATCH 12/32] Get uncompiled calculate prototype fully working. --- nimbleModel/DESCRIPTION | 2 +- nimbleModel/NAMESPACE | 3 + ...{declFxnBaseClass.R => declFunBaseClass.R} | 16 +- nimbleModel/R/instructions.R | 15 +- nimbleModel/R/modelBaseClass.R | 62 ++++--- nimbleModel/R/modelDecl.R | 2 +- nimbleModel/R/modelDef.R | 10 ++ nimbleModel/R/nimbleModel.R | 159 ++++++++++-------- nimbleModel/R/nodeRules.R | 7 +- nimbleModel/tests/testthat/test-nimbleModel.R | 35 ++-- 10 files changed, 170 insertions(+), 141 deletions(-) rename nimbleModel/R/{declFxnBaseClass.R => declFunBaseClass.R} (84%) diff --git a/nimbleModel/DESCRIPTION b/nimbleModel/DESCRIPTION index 693a2ba..770b628 100644 --- a/nimbleModel/DESCRIPTION +++ b/nimbleModel/DESCRIPTION @@ -43,7 +43,7 @@ Collate: varRange.R varRules.R varStore.R - declFxnBaseClass.R + declFunBaseClass.R modelBaseClass.R instructions.R nimbleModel.R diff --git a/nimbleModel/NAMESPACE b/nimbleModel/NAMESPACE index 57a7f59..a7cc763 100644 --- a/nimbleModel/NAMESPACE +++ b/nimbleModel/NAMESPACE @@ -69,3 +69,6 @@ export(messageIfVerbose) export(calc_dmnormAltParams) export(calc_dwishAltParams) + +export(nimbleModel) +export(makeInstrList) diff --git a/nimbleModel/R/declFxnBaseClass.R b/nimbleModel/R/declFunBaseClass.R similarity index 84% rename from nimbleModel/R/declFxnBaseClass.R rename to nimbleModel/R/declFunBaseClass.R index d35aa9c..1f66749 100644 --- a/nimbleModel/R/declFxnBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -1,6 +1,6 @@ #' @export -declFxnBase_nClass <- nClass( - classname = "declFxnBase_nClass", +declFunBase_nClass <- nClass( + classname = "declFunBase_nClass", Cpublic = list( ## model = 'modelBase_nClass', ping = nFunction( @@ -20,11 +20,11 @@ declFxnBase_nClass <- nClass( }, returnType = 'numericScalar', compileInfo = list(virtual=TRUE) ), - ## TODO: for all these type-specific calculates, how do we call the methods of the declFxn_nClass object? + ## TODO: for all these type-specific calculates, how do we call the methods of the decl_nClass object? calc_0 = nFunction( name = 'calc_0', function(instr = 'instr_nClass') { - ## Presumably this will have access to derive class' `calc_one`? + ## Presumably this will have access to derived class' `calc_one`? return(calc_one(0)) ## calc_one will always has `idx` as arg? }, returnType = 'numericScalar' ), @@ -59,11 +59,11 @@ declFxnBase_nClass <- nClass( ## We haven't dealt with ensuring a virtual destructor when any method is virtual ## For now I did it manually by editing the .h and .cpp predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> - file.path("declFxnBase_nC")), + file.path("declFunBase_nC")), compileInfo=list(interface="full", createFromR = FALSE, - exportName = "declFxnBase_nClass_new", - needed_units = list("nodeInstr_nClass"), - packageNames = c(uncompiled="declFxnBase_nClass_R", compiled="declFxnBase_nClass") + exportName = "declFunBase_nClass_new", + needed_units = list("instr_nClass"), + packageNames = c(uncompiled="declFunBase_nClass_R", compiled="declFunBase_nClass") ) ) diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index d48776b..aaa2ba4 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -46,7 +46,7 @@ range2instr <- function(range) { } ## Eventually think about reordering order of looping for efficiency (and take parallelization into account). -## For the moment, we determine mat vs. seq here and then in declClass calculate we will determine whether to +## For the moment, we determine mat vs. seq here and then in declFunClass calculate we will determine whether to ## vectorize based on whether possible based on the declaration. ## Open question of when to determine if to use parallel calculate. determineInstrType <- function(instr, use_vec = FALSE) { @@ -83,6 +83,7 @@ determineInstrType <- function(instr, use_vec = FALSE) { return(type2itype[[type]]) } +#' @export makeInstrList <- function(model, varRanges, use_vec = FALSE) { if(missing(varRanges)) varRanges <- model$getVarNames() @@ -98,8 +99,9 @@ makeInstrList <- function(model, varRanges, use_vec = FALSE) { instrList <- nList(instr_nClass)$new() numRanges <- length(ranges) instrList$setLength(numRanges) + ord <- order(unlist(lapply(ranges, function(x) x$sortID))) for(i in 1:numRanges) - instrList[[i]] <- instr_nClass$new(ranges[[i]]) + instrList[[i]] <- instr_nClass$new(ranges[[ord[i]]]) return(instrList) } @@ -132,9 +134,12 @@ instr_nClass <- nClass( type = 'integerScalar', sortID = 'integerVector', declID = 'integerScalar' - ), compileInfo = list(interface = "full") # TODO: check on this. + ), compileInfo = list(interface = "full", + createFromR = FALSE, + exportName = "instr_nClass_new", + packageNames = c(uncompiled="instr_nClass_R", compiled="instr_nClass") + ) ) -## TODO: determine how to handle this in terms of it being a predefined nClass -## TODO: see PdV version and determine what `compileInfo` elements are needed. + diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 90abf31..ca3b257 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -20,49 +20,45 @@ modelBase_nClass <- nClass( }, getDependencies = function(nodes, self = TRUE, downstream = FALSE, immediateOnly = FALSE) { nimbleModel:::getDependencies(modelDef, nodes, self, downstream, immediateOnly) + }, + calculate = function(instrList) { + if(inherits(instrList, 'instr_nClass')) { + oneInstr <- instrList + instrList <- nList(instr_nClass)$new() + instrList$setLength(1) + instrList[[1]] <- oneInstr + } + if(!((inherits(instrList, 'nList') || is.list(instrList)) && inherits(instrList[[1]], 'instr_nClass'))) + instrList <- makeInstrList(self, instrList) + ## Assume instrList is ordered (it is done `makeInstrList`). + if(isCompiled()) + return(calculate_impl(instrList)) + logProb <- 0 + for(i in 1:length(instrList)) { + logProb <- logProb + declFunList[[instrList[[i]]$declID]]$calculate(instrList[[i]]) + } + return(logProb) } ), Cpublic = list( - declList = 'nList(declFxnBase_nClass)', + declFunList = 'RcppObject', # This won't actually be used in C++, but needs to be in Cpublic for accessibility. + declFunMapping = 'RcppList', # Not sure what type this should be for use in C++. ping = nFunction( name = "ping", function() {return(TRUE); returnType(logical())}, compileInfo = list(virtual=TRUE) ), - calculate = nFunction( - ## TODO: What is the difference between having this as Cpublic with separate C_fun and having in R_public? - name = "calculate", + calculate_impl = nFunction( + name = "calculate_impl", function(instrList) { - cat("In uncompiled calculate\n") - if(inherits(instrList, 'instr_nClass')) - instrList <- list(instrList) - if(FALSE) { - ## TODO: self is a Cpub_uncompiled obj, not full specialized model class. - ## So this doesn't work as we need self$modelDef in `makeInstrList()`. - if(!(is.list(instrList) && inherits(instrList[[1]], 'instr_nClass'))) - instrList <- makeInstrList(self, instrList) - } - logProb <- 0 - ord <- order(unlist(lapply(instrList, function(x) x$sortID))) - ## This is where uncompiled stepping through the calcInstrList happens. - for(i in 1:length(ord)) { - ## TODO: need to sort out this lookup process. - ## nodeIdx <- instr$declID - ## nodemember_name <- self$nodeObjNames[nodeIdx] # nodeObjNames is found in the derived class - logProb <- logProb + declList[[instrList[[ord[i]]]$declID]]$calculate(instrList[[ord[i]]]) - } - return(logProb) + cat("Uncompiled `calculate_impl` should never be called.\n") + return(0) }, returnType = 'numericScalar', compileInfo = list( - C_fun = function(instrList='nList(instr_nClass)') { - logProb <- 0 - ## For now assuming instructions are in order. - for(i in 1:length(instrList)) { - ## nodemember_name <- self$nodeObjNames[instrList[[i]]$declID] - logProb <- logProb + declList[[instrList[[i]]$declID]]$calculate(instrList[[i]]) - } - return(logProb) + C_fun = function(instrList = 'nList(instr_nClass)') { + ## TODO: consider whether instrList will be ordered and/or how C++ will see the decl indexing info. + cppLiteral('modelClass_::calculate(instrList);') }, virtual=TRUE ) @@ -72,8 +68,8 @@ modelBase_nClass <- nClass( predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("modelBase_nC")), compileInfo=list(interface="full", createFromR = FALSE, - Hincludes = c('"declFxnBase_nClass_c_.h"'), #, '"calcInstrList_nClass_c_.h"'), # "declFxnBase_nClass_c_.h" needed for package = TRUE - needed_units = list("declFxnBase_nClass","instr_nClass"), + Hincludes = c('"declFunBase_nClass_c_.h"'), + needed_units = list("declFunBase_nClass","instr_nClass"), exportName = "modelBase_nClass_new", packageNames = c(uncompiled="modelBase_nClass_R", compiled="modelBase_nClass") ) diff --git a/nimbleModel/R/modelDecl.R b/nimbleModel/R/modelDecl.R index 685279a..95cde1b 100644 --- a/nimbleModel/R/modelDecl.R +++ b/nimbleModel/R/modelDecl.R @@ -118,7 +118,7 @@ modelDeclClass <- R6Class( ## Create declRule and symbolic RHS pieces. processDecl = function(nimFunNames, constants = list(), envir) { - declRule <<- declRuleClass$new(self, sourceLineNumber, context, constants) + declRule <<- declRuleClass$new(self, 0, context, constants) makeSymbolicParentNodes(nimFunNames, constants, envir) invisible(NULL) }, diff --git a/nimbleModel/R/modelDef.R b/nimbleModel/R/modelDef.R index 28db07a..7e0d0e5 100644 --- a/nimbleModel/R/modelDef.R +++ b/nimbleModel/R/modelDef.R @@ -16,6 +16,8 @@ modelDefClass <- R6Class( contexts = list(), constants = list(), declInfo = list(), + declFunNameToIndex = list(), + declFunIndexToName = NULL, downstreamRules = NULL, upstreamRules = NULL, calcRules = NULL, @@ -53,6 +55,7 @@ modelDefClass <- R6Class( addRemainingDotParams() ## Add additional altParams as needed. replaceAllConstants() ## Simplify expressions introduced in `addRemainingDotParams`. processDecls(userEnv) ## Create declRules and set up symbolicParentNodes (and flags dynamic indexing). + assignDeclIDs() ## Set sequential declID values and declFun mapping. genAltParams() ## Create altParam expressions and create `calculateCode` (without altParams). genBounds() ## Create bound expressions (modifying `calculateCode`). @@ -546,6 +549,13 @@ modelDefClass <- R6Class( invisible(NULL) }, + assignDeclIDs = function() { + for(i in seq_along(declInfo)) + declInfo[[i]]$declRule$ID <- as.character(i) + declFunNameToIndex <<- as.list(1:length(declInfo)) + names(declFunNameToIndex) <<- paste("declFun", 1:length(declInfo), sep = "_") + }, + ## Add additional altParams not already addressed in getting canonical params. addRemainingDotParams = function() { for(iDecl in seq_along(declInfo)) { diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index 0221df6..03952f0 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -2,6 +2,7 @@ ## but with nCompiler, we need a modelClass to compile and then we can create an instance. ## If we create an instance as the output here, one can't then compile that with an algorithm via `nCompile`. ## Need to think more about the workflow for nimble 2.0. +#' @export nimbleModel <- function(code, constants = list(), data = list(), @@ -17,41 +18,39 @@ nimbleModel <- function(code, buildDerivs = getNimbleOption('buildModelDerivs'), userEnv = parent.frame()) { ## TODO: arg list taken from `nimble`. Revisit which options are needed. - ## For the moment this goes through nimbleModel R6 class and then nCompiler class. Clean that up once ideas are in place. + ## For the moment this goes through (original) nimbleModel R6 class and then nimbleModel nClass. Clean that up once ideas are in place. ## Presumably everything would be in Rpublic initialize for modelBaseClass, so this function will just call modelBase_nClass$new(). - m <- modelClass$new(name = name, code = code, constants = constants, data = data, inits = inits, dimensions = dimensions, userEnv = userEnv) - modelClassInstance <- make_modelClass_from_nimbleModel(m) - if(compile) modelClassInstance <- nCompile(modelClassInstance) - if(returnClass) return(modelClassInstance) # Standard use for when compiling a model(class) and algo(class) together. - model <- modelClassInstance$new() # Otherwise return model object for manipulation from R. + nm <- modelClass$new(name = name, code = code, constants = constants, data = data, inits = inits, dimensions = dimensions, userEnv = userEnv) + specificModelClass <- make_modelClass_from_nimbleModel(nm) + if(compile) specificModelClass <- nCompile(specificModelClass) + if(returnClass) return(specificModelClass) # Standard use for when compiling a model(class) and algo(class) together. + model <- specificModelClass$new() # Otherwise return model object for manipulation from R. } make_modelClass_from_nimbleModel <- function(m, compile=FALSE) { mDef <- m$modelDef - allVarInfo <- get_varInfo_from_nimbleModel(m) - modelVarInfo <- allVarInfo$vars - declFxnNames <- character() + modelVarInfo <- get_varInfo_from_nimbleModel(m) declInfoList <- list() - declFxnList <- list() + declFunClassList <- list() # two vectors for canonical use for calculation instructions # to move between names and indices of declFxns: + declFunNames <- names(mDef$declFunNameToIndex) for(i in seq_along(mDef$declInfo)) { declInfo <- mDef$declInfo[[i]] decl_methods <- make_decl_methods_from_declInfo(declInfo) declVars <- decl_methods |> lapply(\(x) all.vars(body(x))) |> unlist() |> unique() |> setdiff(c("idx", "LocalNewLogProb_", "LocalAns_", "model")) %||% character() - declVarInfo <- modelVarInfo[declVars] - SLN <- declInfo$sourceLineNumber - decl_classname <- paste0("declClass_", SLN) # name of an nClass generator - decl_RvarName <- paste0("declFxn_", SLN) # name of an R variable holding the nClass generator - decl_membername <- paste0("decl_", SLN) # name of model member variable holding an instance of the nClass - # Currently, we can't just make a list of these but need them as named objects in the environment - declFxnList[[decl_RvarName]] <- make_declFxn_nClass(declVarInfo, decl_methods, decl_classname) - assign(decl_RvarName, - declFxnList[[decl_RvarName]] - ) - declInfoList[[i]] <- make_decl_info_for_model_nClass(decl_membername, decl_RvarName, decl_classname, declVarInfo) + declVarInfo <- modelVarInfo$vars[declVars] + declID <- as.numeric(declInfo$declRule$ID) # Formerly `sourceLineNumber`, which may not be unique. + declFun_membername <- declFunNames[i] + declFun_classname <- sub("declFun", "declFunClass", declFun_membername) # name of an nClass generator + declFun_RvarName <- sub("declFun", "declFunClassGen", declFun_membername) # name of R var holding the nClass generator + # Currently, we can't just make a list of these but need them as named objects in the environment, + # which is passed into the nClass() call so that `initialize()` can use them via R's scoping. + assign(declFun_RvarName, make_declFun_nClass(declVarInfo, decl_methods, declFun_classname, declID)) + declInfoList[[i]] <- make_decl_info_for_model_nClass(declFun_membername, declFun_RvarName, declFun_classname, declVarInfo) } - modelClassInstance <- makeModel_nClass(modelVarInfo, declInfoList, inits = m$origInits, data = m$origData, model = m, classname = "my_model", env = environment()) + modelClassInstance <- makeModel_nClass(modelVarInfo, declInfoList, inits = m$origInits, data = m$origData, + model = m, classname = "my_model", env = environment()) } @@ -79,10 +78,11 @@ nm_addModelDollarSign <- function(expr, exceptionNames = character(0)) { return(expr) } -# Turn variables and methods into a declFxn nClass -make_declFxn_nClass <- function(varInfo = list(), +# Turn variables and methods into a declFun nClass +make_declFun_nClass <- function(varInfo = list(), methods = list(), - classname) { + classname, + declID) { # varInfo will be a list (names not used) of name, nDim, sizes. # These are the model member variables to be used by the declFxn. # They will be used in a constructor to set up C++ references to model variables. @@ -115,10 +115,11 @@ make_declFxn_nClass <- function(varInfo = list(), } else { initializersList <- character() } + ## TODO: I don't think this labelCreator (or the one for the model) exist (though they shouldn't be used...) if(missing(classname)) - classname <- declFxnLabelCreator() + classname <- declLabelCreator() - baseclass <- paste0("declFxnClass_<", classname, ">") + baseclass <- paste0("declFunClass_<", classname, ">") # Rpublic method to set the model pointer/reference. setModel <- function(model) { @@ -131,9 +132,9 @@ make_declFxn_nClass <- function(varInfo = list(), } # This was a prototype - declFxn_nClass <- substitute( + declFun_nClass <- substitute( nClass( - inherit = declFxnBase_nClass, + inherit = declFunBase_nClass, classname = CLASSNAME, Rpublic = RPUBLIC, Cpublic = CPUBLIC, @@ -143,6 +144,7 @@ make_declFxn_nClass <- function(varInfo = list(), ), list( CPUBLIC = c( + declID = declID, list( nFunction( initFun, @@ -158,40 +160,39 @@ make_declFxn_nClass <- function(varInfo = list(), CLASSNAME = classname, BASECLASS = baseclass )) - eval(declFxn_nClass) + eval(declFun_nClass) } #test <- nCompiler:::type2symbol('CppVar(baseType = type2cpp("numericVector"), ref=TRUE, const=TRUE)') # Make all the info needed to include a decl in a model class. -# The declFxn_nClass should be created first. +# The decl_nClass should be created first. # Currently it needs to have a name to include in nCompile(). Later we might be able to pass the object itself # At first drafting this is fairly trivial but could grow in complexity. make_decl_info_for_model_nClass <- function(membername, - declFxnName, + declFunName, classname, varInfo = list() ) { ctorArgs <- varInfo |> lapply(\(x) x$name) |> unlist() - list(declFxnName = declFxnName, + list(declFunName = declFunName, membername = membername, classname = classname, ctorArgs = ctorArgs) } -makeModel_nClass <- function(varInfo, +makeModel_nClass <- function(modelVarInfo, decls = list(), classname, - sizes = list(), inits = list(), data = list(), model = NULL, env = parent.frame() ) { - # varInfo will be a list (names not used) of name, nDim, sizes. - CpublicModelVars <- varInfo |> lapply(\(x) paste0("numericArray(nDim=",x$nDim,")")) - names(CpublicModelVars) <- varInfo |> lapply(\(x) x$name) |> unlist() + ## varInfo will be a list (names not used) of name, nDim, sizes. + CpublicModelVars <- modelVarInfo$vars |> lapply(\(x) paste0("numericArray(nDim=",x$nDim,")")) + names(CpublicModelVars) <- modelVarInfo$vars |> lapply(\(x) x$name) |> unlist() opDefs <- list( base_ping = nCompiler:::getOperatorDef("custom_call"), setup_decl_mgmt = nCompiler:::getOperatorDef("custom_call"), @@ -236,26 +237,21 @@ makeModel_nClass <- function(varInfo, resize_from_list = nFunction( name = "resize_from_list", function(Rlist) {for(v in names(Rlist)) - if(exists(v, self, inherits=FALSE)) self[[v]] <- nArray(dim=Rlist[[v]])}, + if(exists(v, self, inherits=FALSE)) self[[v]] <- nArray(value = NA, dim=Rlist[[v]])}, compileInfo = list( C_fun=function(Rlist = 'RcppList') {cppLiteral('modelClass_::resize_from_list(Rlist);')}) ) ) - # decls will be a list of membername, declFxnName, (decl) classname, ctorArgs (list) + # decls will be a list of membername, declName, (decl) classname, ctorArgs (list) decl_pieces <- decls |> lapply(\(x) { #nClass_type <- paste0(x$declFxnName, "()") init_string <- paste0('nCpp("', x$membername, '( new ', x$classname, '(', paste0(x$ctorArgs, collapse=","), '))")') - list(nClass_type = x$declFxnName, - init_string = init_string, - membername = x$membername) + list(nClass_type = x$declFunName, + init_string = init_string) }) - declObjNames <- (decl_pieces |> lapply(\(x) x$membername) |> unlist()) %||% character() - # declObjNames also serves for canonical lookup of names by index. - # e.g. declObjNames[i] gives the member name of the index=i decl member. - declObjName_2_declIndex <- seq_along(declObjNames) |> structure(names=declObjNames) - # Inversely, declobjName_2_declIndex["decl_3"] gives the index of that decl. - CpublicDeclFuns <- decl_pieces |> lapply(\(x) x$nClass_type) |> setNames(declObjNames) + + CpublicDeclFuns <- decl_pieces |> lapply(\(x) x$nClass_type) |> setNames(names(model$modelDef$declFunNameToIndex)) # CpublicDeclFuns <- list( # beta_decl = 'decl_dnorm()' # ) @@ -272,33 +268,51 @@ makeModel_nClass <- function(varInfo, # here is a magic flag. if(isTRUE(.GlobalEnv$.debugModelInit)) browser() super$initialize() - if(isCompiled()) - self$setup_decl_mgmt_from_names(self$declObjNames) - if(!isCompiled()) { - for(declObj in self$declObjNames) { - self[[declObj]] <- eval(as.name(self$CpublicDeclFuns[[declObj]]))$new() - self[[declObj]]$setModel(self) + ## TODO: figure out which of the following to the base class initialize. + ## For now just putting these here in one place. + declFunNames <- names(self$declFunNameToIndex) + if(isCompiled()) { + self$setup_decl_mgmt_from_names(declFunNames) + } else { + self$declFunList <- list() + length(self$declFunList) <- length(declFunNames) + names(self$declFunList) <- declFunNames + for(declFunName in declFunNames) { + self[[declFunName]] <- eval(as.name(self$CpublicDeclFuns[[declFunName]]))$new() + self[[declFunName]]$setModel(self) + self$declFunList[[self$declFunNameToIndex[[declFunName]]]] <- self[[declFunName]] } } + + ## TODO: create a merge_and_set function that handles all three of the following. - # First expand any provided or default sizes - # To-Do possibly merge the argument sizes and defaultSizes by element. - if(missing(sizes)) sizes <- self$defaultSizes - if(length(sizes)) resize_from_list(sizes) - - # Then any provided inits over-ride any provided sizes - # To-Do: Ditto - if(missing(inits)) inits <- self$defaultInits + allSizes <- self$defaultSizes + if(!missing(sizes)) + for(nm in names(sizes)) + allSizes[[nm]] <- sizes[[nm]] + ## TODO: should we handle 0-dim sizes elsewhere? + allSizes <- allSizes[sapply(allSizes, length) > 0] + if(length(allSizes)) resize_from_list(allSizes[sapply(allSizes, length) > 0]) + + allInits <- self$defaultInits + if(!missing(inits)) + for(nm in names(inits)) + allInits[[nm]] <- inits[[nm]] + if(length(allInits)) set_from_list(allInits) + + if(missing(inits)) { + allInits <- self$defaultInits + } else if(length(inits)) set_from_list(inits) # TODO: do we want to handle data differently? # TODO: need to work through not setting as 'data' if values are NA; # check back against how dataRules work in nimbleModel work. - if(missing(data)) data <- self$defaultData - if(length(data)) set_from_list(data) -browser() - - + allData <- self$defaultData + if(!missing(inits)) + for(nm in names(inits)) + allData[[nm]] <- inits[[nm]] + if(length(allData)) set_from_list(allData) } baseclass <- paste0("modelClass_<", classname, ">") # CpublicDeclFuns has elements like "decl_1 = quote(declFxn_1())" @@ -311,7 +325,7 @@ browser() classname = CLASSNAME, inherit = modelBase_nClass, compileInfo = list(opDefs = OPDEFS, - nClass_inherit = list(base=BASECLASS)#, + nClass_inherit = list(base=BASECLASS) #, # needed_units = list("declFxnBase_nClass"), # needed for package=TRUE # Hincludes = '"declFxnBase_nClass_c_.h"' # needed for package=TRUE ), @@ -322,9 +336,8 @@ browser() list(OPDEFS = opDefs, # A list of individual elements RPUBLIC = list(initialize=initialize, - declObjNames = declObjNames, - declObjName_2_declIndex = declObjName_2_declIndex, - defaultSizes = sizes, + declFunNameToIndex = model$modelDef$declFunNameToIndex, + defaultSizes = modelVarInfo$sizes, defaultInits = inits, defaultData = data, modelDef = model$modelDef, @@ -346,6 +359,8 @@ get_varInfo_from_nimbleModel <- function(model) { logProbVars <- mDef$logProbVarInfo |> extract() # The resize_from_list method will error out if a scalar is included. # The maxs is empty for scalars, so they are automatically omitted from the sizes result here. + # TODO: CJP sees scalars included as numeric(0) in sizes, so not omitted. Will this be a problem for resize_from_list? + # TODO: If ok, put sizes info into the same list as vars info. extract_sizes <- \(x) x|> lapply(\(x) x$maxs) sizes <- mDef$varInfo |> extract_sizes() logProb_sizes <- mDef$logProbVarInfo |> extract_sizes() diff --git a/nimbleModel/R/nodeRules.R b/nimbleModel/R/nodeRules.R index 42652e3..db65d4b 100644 --- a/nimbleModel/R/nodeRules.R +++ b/nimbleModel/R/nodeRules.R @@ -127,11 +127,6 @@ declRuleClass <- R6Class( originalIndexingRule = NULL, # Determines original indexing (based on context). decl = NULL, # Full declInfo; nodeRuleClass$expr is just LHS. calculate = NULL, # Generic function for calculation. - ID = NULL, # Unique ID that will be the index of the declClass in C++ (TBD how this is baked in). - ## TODO: remove this: - test = rep(0, 10), ## test element used for testing calculation while modelDef doesn't have acccess to a model - test2 = matrix(0, 3, 5), - initialize = function(decl, ID, context = modelContextClass$new(), constants = list()) { decl <<- decl super$initialize(decl$code[[2]], ID, context = context, constants = constants) @@ -240,7 +235,7 @@ calcRuleClass <- R6Class( indexingRange <- declRule$originalIndexingRule$apply(inputRange) if(is.null(indexingRange)) return(NULL) - result <- calcRangeClass$new(varName, indexingRange, declRule$ID, sortID, multiSortIDindex) + result <- calcRangeClass$new(varName, indexingRange, as.numeric(declRule$ID), sortID, multiSortIDindex) return(result) }, diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index d6906c2..376e973 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -207,31 +207,33 @@ if(FALSE) { ## CJP experimentation with nimbleModel, modelClass stuff. library(nimbleModel);library(nCompiler) -# source('modelBaseClass.R') -# source('declFxnBaseClass.R') -# source('nimbleModel.R') -# source('instructions.R') - code <- quote({ sd ~ dunif(0, 10) for(i in 1:5) { - z[i] <- x[i+1] + 10 + # z[i] <- x[i+1] + 10 y[i] ~ dnorm(x[i+1], sd = sd) } }) + inits <- list(sd = 1.5) data <- list(y = rnorm(5)) nm <- modelClass$new(code, inits = inits, data = data) mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) -m <- mclass$new(inits=list(sd=5)) -## m$calculate('sd') # Doesn't work because Cpublic calculate can't run makeInstrList as it can't access modelDef. +# .debugModelInit <- TRUE +m <- mclass$new(inits=list(sd=5, x = rnorm(6))) -instrList <- nimbleModel:::makeInstrList(m, 'sd') +m$calculate('sd') +instrList <- makeInstrList(m, 'sd') +m$calculate(instrList) +instrList <- makeInstrList(m, 'y') m$calculate(instrList) -instrList <- nimbleModel:::makeInstrList(m, 'y') + +instrList <- makeInstrList(m, c('y','sd')) # ordering should be done internally m$calculate(instrList) +m$calculate(c('y','sd')) # ordering should be done internally + # cr <- m$modelDef$calcRules[['y']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['y']]$rules[[1]]$apply('y')) # cr <- m$modelDef$calcRules[['sd']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['sd']]$rules[[1]]$apply('sd')) @@ -240,7 +242,14 @@ out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calc_one(0) out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calc_0(instrList[[1]]) out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calculate(instrList[[1]]) -# how initialize a list of declFxns? +mclass <- nimbleModel(code, data = data, inits = inits) +m <- mclass$new(inits=list(sd=5, x = rnorm(6))) +m$calculate(c('y','sd')) + +m <- nimbleModel(code, data = data, inits = inits, returnClass = FALSE) + +## Try out compilation; see nCompiler's test-nimbleModel.R. + # How get nCompiler to know about base class not in nCompiler? # tmp=nList(nimbleModel:::declFxnBase_nClass) @@ -273,7 +282,3 @@ obj$myfun(3) ## full workflow with getDeps -## work on sortID - - - From 89b5d5b4c884b6ddc6779f50e89d33464354d14b Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 09:40:36 -0700 Subject: [PATCH 13/32] Cleanup stuff related to modelClass and modelBaseClass. --- nimbleModel/R/model.R | 13 ++-- nimbleModel/R/modelBaseClass.R | 15 ++++- nimbleModel/R/modelDecl.R | 6 +- nimbleModel/R/modelDef.R | 8 --- nimbleModel/R/nimbleModel.R | 5 +- nimbleModel/R/nodeRules.R | 59 +------------------ nimbleModel/tests/testthat/test-nimbleModel.R | 4 +- 7 files changed, 30 insertions(+), 80 deletions(-) diff --git a/nimbleModel/R/model.R b/nimbleModel/R/model.R index 2dc0b64..4bdc65d 100644 --- a/nimbleModel/R/model.R +++ b/nimbleModel/R/model.R @@ -2,6 +2,12 @@ ## static information, data information, and methods for querying the model ## structure. +## For the moment this overlaps with the custom model class we create +## for each model using nCompiler. That model class takes some of the +## fields and calls some of the methods set up here. + +## TODO: possibly work all of this into modelBase_nClass. + ## Will need to do some work to extend this to get full current behavior ## where the model is created by `nimbleModel` and the custom model class ## contains fields for the different variables. @@ -67,11 +73,6 @@ modelClass <- R6Class( makeDataRules(data) makePredictiveRules() - - ## Do this once we have a custom model class with fields we can assign into. - ## setData(data) - ## setInits(inits) - }, makeDataRules = function(data) { @@ -126,7 +127,7 @@ modelClass <- R6Class( nonpredictiveRules <<- candidateRules }, - + ## TODO: should this be a standalone function like getNodes, getDependencies? getVarNames = function(includeLogProb = FALSE, nodeRanges) { if(missing(nodeRanges)){ if(includeLogProb) return(modelDef$varNames) diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index ca3b257..148b0fe 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -2,7 +2,6 @@ modelBase_nClass <- nClass( classname = "modelBase_nClass", Rpublic = list( - ## TODO: bring in methods and fields from nimbleModel:::modelClass. modelDef = NULL, dataRules = NULL, nondataRules = NULL, @@ -19,8 +18,20 @@ modelBase_nClass <- nClass( } }, getDependencies = function(nodes, self = TRUE, downstream = FALSE, immediateOnly = FALSE) { - nimbleModel:::getDependencies(modelDef, nodes, self, downstream, immediateOnly) + nimbleModel::getDependencies(modelDef, nodes, self, downstream, immediateOnly) }, + getParents = function(nodes, self = TRUE, upstream = FALSE, immediateOnly = FALSE) { + nimbleModel::getParents(modelDef, nodes, self, upstream, immediateOnly) + }, + getNodes = function(nodes, stochOnly = FALSE, determOnly = FALSE, + includeData = TRUE, dataOnly = FALSE, + includePredictive = TRUE, predictiveOnly = FALSE, + includeRHSonly = FALSE, + topOnly = FALSE, latentOnly = FALSE, endOnly = FALSE) { + nimbleModel::getNodes(modelDef, stochOnly, determOnly, includeData, dataOnly, + includePredictive, predictiveOnly, includeRHSonly, + topOnly, latentOnly, endOnly) + }, calculate = function(instrList) { if(inherits(instrList, 'instr_nClass')) { oneInstr <- instrList diff --git a/nimbleModel/R/modelDecl.R b/nimbleModel/R/modelDecl.R index 95cde1b..3ab444c 100644 --- a/nimbleModel/R/modelDecl.R +++ b/nimbleModel/R/modelDecl.R @@ -8,7 +8,7 @@ modelDeclClass <- R6Class( public = list( context = NULL, # FUTURE: might just use declRule$context sourceLineNumber = NULL, - stoch = FALSE, # Need this here as used before declRule created. + stoch = FALSE, code = NULL, distributionName = NA, valueExpr = NULL, @@ -283,10 +283,6 @@ modelDeclClass <- R6Class( invisible(NULL) }, - buildFunctions = function() { - declRule$buildFunctions(calculateCode, genLogProbExpr()) - }, - genLogProbExpr = function() { if(declRule$decl$stoch) { logProbExpr <- code[[2]] diff --git a/nimbleModel/R/modelDef.R b/nimbleModel/R/modelDef.R index 7e0d0e5..84ee7be 100644 --- a/nimbleModel/R/modelDef.R +++ b/nimbleModel/R/modelDef.R @@ -76,7 +76,6 @@ modelDefClass <- R6Class( warnRHSonlyDynamicIndexing() - buildFunctions() ## Generate calculate and other functions. invisible(NULL) }, @@ -878,13 +877,6 @@ modelDefClass <- R6Class( } } invisible(NULL) - }, - - buildFunctions = function() { - for(i in seq_along(declInfo)) { - declInfo[[i]]$buildFunctions() - } - invisible(NULL) } ) ) diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index 03952f0..b4b03b5 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -341,7 +341,10 @@ makeModel_nClass <- function(modelVarInfo, defaultInits = inits, defaultData = data, modelDef = model$modelDef, - ## TODO: add other fields from `nimbleModel::modelClass` such as dataRules, predictiveRules, etc. + dataRules = model$dataRules, + nondataRules = model$nondataRules, + predictiveRules = model$predictiveRules, + nonpredictiveRules = model$nonpredictiveRules, CpublicDeclFuns = CpublicDeclFuns), # A concatenation of lists CPUBLIC = c(CpublicDeclFuns, CpublicModelVars, CpublicCtor, CpublicMethods), diff --git a/nimbleModel/R/nodeRules.R b/nimbleModel/R/nodeRules.R index db65d4b..f1f51f8 100644 --- a/nimbleModel/R/nodeRules.R +++ b/nimbleModel/R/nodeRules.R @@ -7,18 +7,12 @@ ## rather it simply represents the valid index values for a variable. ## There is one declRule for each declaration in a model, representing the indexing for the LHS variable. -## A declRule contains the `calculate` function (i.e., the nodeFunction) that operates on a -## single set of index values. ## calcRules are generated by starting with declRules and then fracturing (with `fracture`) ## based on top-down processing. This produces a calcRule for each set of nodes ## from a declaration that can be calculated together (same sortID) ## (as well as the special case of state-space model type formulations). -## TODO: work on `simulate`, `getParam` and other related model methods; will these be part or -## `calcRules`? - - ## Base class for all node-related classes nodeRuleClass <- R6Class( classname = "nodeRuleClass", @@ -117,8 +111,7 @@ nodeRuleClass <- R6Class( ) ) -## Class for representing nodes at the declaration level, containing -## calculate and other nodeFunctions. +## Class for representing nodes at the declaration level. declRuleClass <- R6Class( classname = "declRuleClass", portable = FALSE, @@ -126,61 +119,13 @@ declRuleClass <- R6Class( public = list( originalIndexingRule = NULL, # Determines original indexing (based on context). decl = NULL, # Full declInfo; nodeRuleClass$expr is just LHS. - calculate = NULL, # Generic function for calculation. initialize = function(decl, ID, context = modelContextClass$new(), constants = list()) { decl <<- decl super$initialize(decl$code[[2]], ID, context = context, constants = constants) ## `expr` in is parent class. originalIndexingRule <<- originalIndexingRuleClass$new(expr, context, constants) - }, - - buildFunctions = function(code, logProbExpr) { - buildCalculateFun(code, logProbExpr, context) - }, - - buildCalculateFun = function(code, logProbExpr, context) { - newCode <- code - if(newCode[[1]] == '<-') { - newCode <- quote(A <<- B) - newCode[2:3] <- code[2:3] - } - replacements <- sapply(seq_along(context$singleContexts), - function(i) parse(text = paste0('idx[',i,']'))[[1]]) - names(replacements) <- context$indexVarNames - - for(i in seq_along(context$singleContexts)) { - newCode <- eval(substitute(substitute(e, replacements), list(e = newCode))) - logProbExpr <- eval(substitute(substitute(e, replacements), list(e = logProbExpr))) - } - - if(decl$stoch) { - ## Insert 'logProb_' and change to assignment, moving LHS in as first argument. - finalCode <- quote(A <<- B) - finalCode[[2]] <- logProbExpr - finalCode[[3]] <- newCode[[3]] - len <- length(finalCode[[3]]) - if(len > 1) { - finalCode[[3]][3:(len+1)] <- finalCode[[3]][2:len] - names(finalCode[[3]])[3:(len+1)] <- names(finalCode[[3]])[2:len] - } - finalCode[[3]][[2]] <- newCode[[2]] - names(finalCode[[3]])[2] <- "" - finalCode[[3]][[len+2]] <- 1 - names(finalCode[[3]])[len+2] <- "log" - calculate <<- function(idx) { - ## logProb_y <- array(0, rep(100, nvals)) # TODO: placeholder so logProb storage exists for testing - } - ## body(calculate)[[length(body(calculate))+1]] <<- finalCode - body(calculate) <<- finalCode - } else { - calculate <<- function(idx) {} - body(calculate) <<- newCode - } - ## TODO: will need to deal with logProb for mv node having single value inserted. - ## TODO: will need to deal with the various complexities we currently deal with - alt params, truncation, etc. } - ) ) @@ -381,7 +326,7 @@ calcRuleClass <- R6Class( ) ## calcRanges manage the calculation for one or more nodes, handling the indexing, and -## calling out to the declRule `calculate` function. +## calling out to the declFun `calculate` function. calcRangeClass <- R6Class( classname = "calcRangeClass", portable = FALSE, diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 376e973..a8262a2 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -248,6 +248,9 @@ m$calculate(c('y','sd')) m <- nimbleModel(code, data = data, inits = inits, returnClass = FALSE) +m$calculate(m$getDependencies('sd')) + + ## Try out compilation; see nCompiler's test-nimbleModel.R. @@ -280,5 +283,4 @@ obj$pop(rnorm(3),rnorm(5)) obj$myfun(3) -## full workflow with getDeps From f27c17acdb885c21b522c67dc2bced9078c31e06 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 10:12:44 -0700 Subject: [PATCH 14/32] Add simulate declFun. --- nimbleModel/R/declFunBaseClass.R | 41 ++++++++++++++++++- nimbleModel/R/modelBaseClass.R | 38 +++++++++++++++-- nimbleModel/R/modelDef.R | 4 ++ nimbleModel/tests/testthat/test-nimbleModel.R | 7 +++- 4 files changed, 84 insertions(+), 6 deletions(-) diff --git a/nimbleModel/R/declFunBaseClass.R b/nimbleModel/R/declFunBaseClass.R index 1f66749..e269dd0 100644 --- a/nimbleModel/R/declFunBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -20,11 +20,9 @@ declFunBase_nClass <- nClass( }, returnType = 'numericScalar', compileInfo = list(virtual=TRUE) ), - ## TODO: for all these type-specific calculates, how do we call the methods of the decl_nClass object? calc_0 = nFunction( name = 'calc_0', function(instr = 'instr_nClass') { - ## Presumably this will have access to derived class' `calc_one`? return(calc_one(0)) ## calc_one will always has `idx` as arg? }, returnType = 'numericScalar' ), @@ -54,6 +52,45 @@ declFunBase_nClass <- nClass( logProb <- logProb + calc_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? return(logProb) }, returnType = 'numericScalar' + ), + + simulate = nFunction( + name = "simulate", + fun = function(instr = 'instr_nClass') { + ## TODO: how embed determination of vec and parallel cases here? + if(instr$type == 0) return(sim_0(instr)) + if(instr$type == 1) return(sim_1_seq(instr)) + if(instr$type == 2) return(sim_1_mat(instr)) + if(instr$type == 3) return(sim_1_matp(instr)) + }, + compileInfo = list(virtual=TRUE) + ), + sim_0 = nFunction( + name = 'sim_0', + function(instr = 'instr_nClass') { + sim_one(0) ## sim_one will always has `idx` as arg? + } + ), + sim_1_seq = nFunction( + name = 'sim_1_seq', + function(instr = 'instr_nClass') { + for(i in 1:instr$lens[1]) + sim_one(instr$values[[1]][1]+i) + } + ), + sim_1_mat = nFunction( + name = 'sim_1_mat', + function(instr = 'instr_nClass') { + for(i in 1:instr$lens[1]) + sim_one(instr$values[[1]][i]) + } + ), + sim_1_matp = nFunction( + name = 'sim_1_mat', + function(instr = 'instr_nClass') { + for(i in 1:instr$lens[1]) + sim_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + } ) ), ## We haven't dealt with ensuring a virtual destructor when any method is virtual diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 148b0fe..58412d5 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -23,12 +23,14 @@ modelBase_nClass <- nClass( getParents = function(nodes, self = TRUE, upstream = FALSE, immediateOnly = FALSE) { nimbleModel::getParents(modelDef, nodes, self, upstream, immediateOnly) }, - getNodes = function(nodes, stochOnly = FALSE, determOnly = FALSE, + ## TODO: not working because `nimbleModel::getNodes` needs the model not just modelDef. + ## Once we integrate modelClass with modelBase_nClass, we should be able to pass `self`. + getNodes = function(nodes = NULL, stochOnly = FALSE, determOnly = FALSE, includeData = TRUE, dataOnly = FALSE, includePredictive = TRUE, predictiveOnly = FALSE, includeRHSonly = FALSE, topOnly = FALSE, latentOnly = FALSE, endOnly = FALSE) { - nimbleModel::getNodes(modelDef, stochOnly, determOnly, includeData, dataOnly, + nimbleModel::getNodes(modelDef, nodes, stochOnly, determOnly, includeData, dataOnly, includePredictive, predictiveOnly, includeRHSonly, topOnly, latentOnly, endOnly) }, @@ -49,6 +51,22 @@ modelBase_nClass <- nClass( logProb <- logProb + declFunList[[instrList[[i]]$declID]]$calculate(instrList[[i]]) } return(logProb) + }, + simulate = function(instrList) { + if(inherits(instrList, 'instr_nClass')) { + oneInstr <- instrList + instrList <- nList(instr_nClass)$new() + instrList$setLength(1) + instrList[[1]] <- oneInstr + } + if(!((inherits(instrList, 'nList') || is.list(instrList)) && inherits(instrList[[1]], 'instr_nClass'))) + instrList <- makeInstrList(self, instrList) + ## Assume instrList is ordered (it is done `makeInstrList`). + if(isCompiled()) + return(simulate_impl(instrList)) + for(i in 1:length(instrList)) { + declFunList[[instrList[[i]]$declID]]$simulate(instrList[[i]]) + } } ), Cpublic = list( @@ -68,11 +86,25 @@ modelBase_nClass <- nClass( returnType = 'numericScalar', compileInfo = list( C_fun = function(instrList = 'nList(instr_nClass)') { - ## TODO: consider whether instrList will be ordered and/or how C++ will see the decl indexing info. + ## NOTE: instrList input will be ordered. cppLiteral('modelClass_::calculate(instrList);') }, virtual=TRUE ) + ), + simulate_impl = nFunction( + name = "simulate_impl", + function(instrList) { + cat("Uncompiled `simulate_impl` should never be called.\n") + return(0) + }, + returnType = 'numericScalar', + compileInfo = list( + C_fun = function(instrList = 'nList(instr_nClass)') { + cppLiteral('modelClass_::simulate(instrList);') + }, + virtual=TRUE + ) ) ), ## See comment above about needing to ensure a virtual destructor diff --git a/nimbleModel/R/modelDef.R b/nimbleModel/R/modelDef.R index 84ee7be..48cc6ec 100644 --- a/nimbleModel/R/modelDef.R +++ b/nimbleModel/R/modelDef.R @@ -896,6 +896,10 @@ modelDefClass <- R6Class( ## Note: data-related flags not handled as that relates to flags on a model ## and not part of modelDef. +## TODO: these should presumably take the model not modelDef as the first arg. +## Once we integrate modelClass with modelBase_nClass, we should be able to +## pass `self` from the getDeps and getParents methods to these functions. + getDependencies <- function(modelDef, nodes, self = TRUE, downstream = FALSE, immediateOnly = FALSE) { diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index a8262a2..c453726 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -203,8 +203,8 @@ if(FALSE) { } ######## - ## CJP experimentation with nimbleModel, modelClass stuff. + library(nimbleModel);library(nCompiler) code <- quote({ @@ -234,6 +234,10 @@ m$calculate(instrList) m$calculate(c('y','sd')) # ordering should be done internally +m$y +m$simulate('y') +m$y + # cr <- m$modelDef$calcRules[['y']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['y']]$rules[[1]]$apply('y')) # cr <- m$modelDef$calcRules[['sd']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['sd']]$rules[[1]]$apply('sd')) @@ -249,6 +253,7 @@ m$calculate(c('y','sd')) m <- nimbleModel(code, data = data, inits = inits, returnClass = FALSE) m$calculate(m$getDependencies('sd')) +m$calculate(m$getDependencies('sd', self = FALSE)) ## Try out compilation; see nCompiler's test-nimbleModel.R. From 25cbc14145d15826c23b11ccb10d4debb5361c69 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 10:33:20 -0700 Subject: [PATCH 15/32] Move model-specific class init into modelBase_nClass. --- nimbleModel/R/modelBaseClass.R | 49 ++++++++++++++++++++++++++++++ nimbleModel/R/nimbleModel.R | 55 ++-------------------------------- 2 files changed, 51 insertions(+), 53 deletions(-) diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 58412d5..84c9101 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -7,6 +7,55 @@ modelBase_nClass <- nClass( nondataRules = NULL, predictiveRules = NULL, nonpredictiveRules = NULL, + initialize = function(sizes = list(), inits = list(), data = list()) { + # It is not very easy to set debug onto the initialize function, so + # here is a magic flag. + if(isTRUE(.GlobalEnv$.debugModelInit)) browser() + super$initialize() + + declFunNames <- names(self$declFunNameToIndex) + if(isCompiled()) { + self$setup_decl_mgmt_from_names(declFunNames) + } else { + self$declFunList <- list() + length(self$declFunList) <- length(declFunNames) + names(self$declFunList) <- declFunNames + for(declFunName in declFunNames) { + self[[declFunName]] <- eval(as.name(self$CpublicDeclFuns[[declFunName]]))$new() + self[[declFunName]]$setModel(self) + self$declFunList[[self$declFunNameToIndex[[declFunName]]]] <- self[[declFunName]] + } + } + + ## TODO: create a merge_and_set function that handles all three of the following. + allSizes <- self$defaultSizes + if(!missing(sizes)) + for(nm in names(sizes)) + allSizes[[nm]] <- sizes[[nm]] + ## TODO: should we handle 0-dim sizes elsewhere? + allSizes <- allSizes[sapply(allSizes, length) > 0] + if(length(allSizes)) resize_from_list(allSizes[sapply(allSizes, length) > 0]) + + allInits <- self$defaultInits + if(!missing(inits)) + for(nm in names(inits)) + allInits[[nm]] <- inits[[nm]] + if(length(allInits)) set_from_list(allInits) + + if(missing(inits)) { + allInits <- self$defaultInits + } else + if(length(inits)) set_from_list(inits) + + ## TODO: do we want to handle data differently? + ## TODO: need to work through not setting as 'data' if values are NA; + ## check back against how dataRules work in nimbleModel work. + allData <- self$defaultData + if(!missing(inits)) + for(nm in names(inits)) + allData[[nm]] <- inits[[nm]] + if(length(allData)) set_from_list(allData) + }, getVarNames = function(includeLogProb = FALSE, nodeRanges) { if(missing(nodeRanges)){ if(includeLogProb) return(modelDef$varNames) diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index b4b03b5..dc70c71 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -32,8 +32,6 @@ make_modelClass_from_nimbleModel <- function(m, compile=FALSE) { modelVarInfo <- get_varInfo_from_nimbleModel(m) declInfoList <- list() declFunClassList <- list() - # two vectors for canonical use for calculation instructions - # to move between names and indices of declFxns: declFunNames <- names(mDef$declFunNameToIndex) for(i in seq_along(mDef$declInfo)) { declInfo <- mDef$declInfo[[i]] @@ -132,6 +130,7 @@ make_declFun_nClass <- function(varInfo = list(), } # This was a prototype + # Actually, we are using this. Ok? // CJP declFun_nClass <- substitute( nClass( inherit = declFunBase_nClass, @@ -263,57 +262,7 @@ makeModel_nClass <- function(modelVarInfo, initializers = decl_pieces |> lapply(\(x) x$init_string) |> unlist()) ) ) |> structure(names = classname) - initialize <- function(sizes = list(), inits = list(), data = list()) { - # It is not very easy to set debug onto the initialize function, so - # here is a magic flag. - if(isTRUE(.GlobalEnv$.debugModelInit)) browser() - super$initialize() - ## TODO: figure out which of the following to the base class initialize. - ## For now just putting these here in one place. - declFunNames <- names(self$declFunNameToIndex) - if(isCompiled()) { - self$setup_decl_mgmt_from_names(declFunNames) - } else { - self$declFunList <- list() - length(self$declFunList) <- length(declFunNames) - names(self$declFunList) <- declFunNames - for(declFunName in declFunNames) { - self[[declFunName]] <- eval(as.name(self$CpublicDeclFuns[[declFunName]]))$new() - self[[declFunName]]$setModel(self) - self$declFunList[[self$declFunNameToIndex[[declFunName]]]] <- self[[declFunName]] - } - } - - ## TODO: create a merge_and_set function that handles all three of the following. - - allSizes <- self$defaultSizes - if(!missing(sizes)) - for(nm in names(sizes)) - allSizes[[nm]] <- sizes[[nm]] - ## TODO: should we handle 0-dim sizes elsewhere? - allSizes <- allSizes[sapply(allSizes, length) > 0] - if(length(allSizes)) resize_from_list(allSizes[sapply(allSizes, length) > 0]) - allInits <- self$defaultInits - if(!missing(inits)) - for(nm in names(inits)) - allInits[[nm]] <- inits[[nm]] - if(length(allInits)) set_from_list(allInits) - - if(missing(inits)) { - allInits <- self$defaultInits - } else - if(length(inits)) set_from_list(inits) - - # TODO: do we want to handle data differently? - # TODO: need to work through not setting as 'data' if values are NA; - # check back against how dataRules work in nimbleModel work. - allData <- self$defaultData - if(!missing(inits)) - for(nm in names(inits)) - allData[[nm]] <- inits[[nm]] - if(length(allData)) set_from_list(allData) - } baseclass <- paste0("modelClass_<", classname, ">") # CpublicDeclFuns has elements like "decl_1 = quote(declFxn_1())" # We provide it in Cpublic to declare C++ member variables with types. @@ -335,7 +284,7 @@ makeModel_nClass <- function(modelVarInfo, ), list(OPDEFS = opDefs, # A list of individual elements - RPUBLIC = list(initialize=initialize, + RPUBLIC = list( declFunNameToIndex = model$modelDef$declFunNameToIndex, defaultSizes = modelVarInfo$sizes, defaultInits = inits, From ed20363cddb715a4d3a55a55a5b4d51a71430e51 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 10:47:49 -0700 Subject: [PATCH 16/32] Remove stray nList experimentation code in test-nimbleModel.R. --- nimbleModel/tests/testthat/test-nimbleModel.R | 28 ------------------- 1 file changed, 28 deletions(-) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index c453726..d5d602e 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -259,33 +259,5 @@ m$calculate(m$getDependencies('sd', self = FALSE)) ## Try out compilation; see nCompiler's test-nimbleModel.R. -# How get nCompiler to know about base class not in nCompiler? -# tmp=nList(nimbleModel:::declFxnBase_nClass) -#Error in self$resolveSym(project_env, ...) : -# In resolveSym method for symbolTBD (, :::), could not resolve an nClass generator. - -## experimenting ((not working) with creating and populating nLists -rNL <- nList(numericVector) -cl <- nClass( - Cpublic =list( - x = 'rNL', - myfun = nFunction( - function(y = 'numericScalar') { - return(y*x[[2]]) - }, returnType = 'numericVector' - ), - pop = nFunction( - function(x1 = 'numericVector', x2='numericVector') { - length(x) <- 3 - - x[[1]] <- x1 # this is still `1` as index in C++ - x[[2]] <- x2 - }) - )) -ccl <- nCompile(cl, rNL=rNL) -obj <- ccl[[1]]$new() -obj$pop(rnorm(3),rnorm(5)) -obj$myfun(3) - From 8b90c9f1df0044bc29ea3d18843cdd9ab1a28e7a Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 27 May 2026 12:37:25 -0700 Subject: [PATCH 17/32] Fix simulate returnType. --- nimbleModel/R/declFunBaseClass.R | 8 ++++---- nimbleModel/R/modelBaseClass.R | 2 -- nimbleModel/R/nimbleModel.R | 2 ++ nimbleModel/tests/testthat/test-nimbleModel.R | 5 ++--- 4 files changed, 8 insertions(+), 9 deletions(-) diff --git a/nimbleModel/R/declFunBaseClass.R b/nimbleModel/R/declFunBaseClass.R index e269dd0..e0710b7 100644 --- a/nimbleModel/R/declFunBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -58,10 +58,10 @@ declFunBase_nClass <- nClass( name = "simulate", fun = function(instr = 'instr_nClass') { ## TODO: how embed determination of vec and parallel cases here? - if(instr$type == 0) return(sim_0(instr)) - if(instr$type == 1) return(sim_1_seq(instr)) - if(instr$type == 2) return(sim_1_mat(instr)) - if(instr$type == 3) return(sim_1_matp(instr)) + if(instr$type == 0) sim_0(instr) + if(instr$type == 1) sim_1_seq(instr) + if(instr$type == 2) sim_1_mat(instr) + if(instr$type == 3) sim_1_matp(instr) }, compileInfo = list(virtual=TRUE) ), diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 84c9101..6783693 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -174,5 +174,3 @@ modelBase_nClass <- nClass( # nCompile(modelBase_nClass, control=list(generate_predefined=TRUE)) -## The two "addModelDollarSign" functions are borrowed directly from nimble. -## This should add model$ in front of any names that are not already part of a '$' expression diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index dc70c71..adfc725 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -51,6 +51,8 @@ make_modelClass_from_nimbleModel <- function(m, compile=FALSE) { model = m, classname = "my_model", env = environment()) } +## The two "addModelDollarSign" functions are borrowed directly from nimble. +## This should add model$ in front of any names that are not already part of a '$' expression nm_addModelDollarSign <- function(expr, exceptionNames = character(0)) { if(is.numeric(expr)) return(expr) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index d5d602e..4b98345 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -220,6 +220,8 @@ data <- list(y = rnorm(5)) nm <- modelClass$new(code, inits = inits, data = data) mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) +cmclass <- nCompile(mclass) + # .debugModelInit <- TRUE m <- mclass$new(inits=list(sd=5, x = rnorm(6))) @@ -258,6 +260,3 @@ m$calculate(m$getDependencies('sd', self = FALSE)) ## Try out compilation; see nCompiler's test-nimbleModel.R. - - - From 9e44971458e475d0c6b9a129b6e8fc610ff29d99 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Thu, 28 May 2026 11:02:01 -0700 Subject: [PATCH 18/32] Take some steps towards compilation of nimbleModels. --- nimbleModel/R/instructions.R | 4 +++- nimbleModel/R/modelBaseClass.R | 7 ++++--- nimbleModel/R/nimbleModel.R | 2 +- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index aaa2ba4..f1a51a0 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -134,7 +134,9 @@ instr_nClass <- nClass( type = 'integerScalar', sortID = 'integerVector', declID = 'integerScalar' - ), compileInfo = list(interface = "full", + ), + predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("instr_nClass")), + compileInfo = list(interface = "full", createFromR = FALSE, exportName = "instr_nClass_new", packageNames = c(uncompiled="instr_nClass_R", compiled="instr_nClass") diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 6783693..ecca61d 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -119,8 +119,9 @@ modelBase_nClass <- nClass( } ), Cpublic = list( - declFunList = 'RcppObject', # This won't actually be used in C++, but needs to be in Cpublic for accessibility. - declFunMapping = 'RcppList', # Not sure what type this should be for use in C++. + ## TODO: using 'RcppObject' was resulting in a symbolTBD error - probably nCompiler issue 186. + declFunList = 'numericScalar', # 'RcppObject', # This won't actually be used in C++, but needs to be in Cpublic for accessibility. + declFunNameToIndex = 'RcppList', # Not sure what type this should be for use in C++. ping = nFunction( name = "ping", function() {return(TRUE); returnType(logical())}, @@ -160,7 +161,7 @@ modelBase_nClass <- nClass( predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("modelBase_nC")), compileInfo=list(interface="full", createFromR = FALSE, - Hincludes = c('"declFunBase_nClass_c_.h"'), + Hincludes = c('"declFunBase_nClass_c_.h","instr_nClass_c_.h"'), needed_units = list("declFunBase_nClass","instr_nClass"), exportName = "modelBase_nClass_new", packageNames = c(uncompiled="modelBase_nClass_R", compiled="modelBase_nClass") diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index adfc725..fd962cc 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -415,7 +415,7 @@ make_decl_method_nFxn <- function(f, name, returnType='numericScalar') { name = name, fun = Rfun, argTypes = list(idx = 'integerVector'), - returnType = returnType, + returnType = T(returnType), compileInfo=list(C_fun=Cfun), ) nFxn From 48c8b0d5a8efb00f754d97629eafe186b6c1d489 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Thu, 28 May 2026 12:19:12 -0700 Subject: [PATCH 19/32] Add a bit more cleanup of uncompiled declFun stuff. Add basic uncompiled nimbleModel tests. --- nimbleModel/R/modelBaseClass.R | 12 +- nimbleModel/R/nimbleModel.R | 2 +- nimbleModel/tests/testthat/test-nimbleModel.R | 190 +++++++++++------- 3 files changed, 130 insertions(+), 74 deletions(-) diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index ecca61d..30d9a31 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -13,7 +13,10 @@ modelBase_nClass <- nClass( if(isTRUE(.GlobalEnv$.debugModelInit)) browser() super$initialize() - declFunNames <- names(self$declFunNameToIndex) + ## TODO: is there a better way to populate declFunNameToIndex in Cpublic? + declFunNameToIndex <- self$declFunNameToIndex_ + + declFunNames <- names(declFunNameToIndex) if(isCompiled()) { self$setup_decl_mgmt_from_names(declFunNames) } else { @@ -23,7 +26,7 @@ modelBase_nClass <- nClass( for(declFunName in declFunNames) { self[[declFunName]] <- eval(as.name(self$CpublicDeclFuns[[declFunName]]))$new() self[[declFunName]]$setModel(self) - self$declFunList[[self$declFunNameToIndex[[declFunName]]]] <- self[[declFunName]] + self$declFunList[[declFunNameToIndex[[declFunName]]]] <- self[[declFunName]] } } @@ -55,6 +58,7 @@ modelBase_nClass <- nClass( for(nm in names(inits)) allData[[nm]] <- inits[[nm]] if(length(allData)) set_from_list(allData) + }, getVarNames = function(includeLogProb = FALSE, nodeRanges) { if(missing(nodeRanges)){ @@ -84,6 +88,8 @@ modelBase_nClass <- nClass( topOnly, latentOnly, endOnly) }, calculate = function(instrList) { + if(missing(instrList)) + instrList <- getVarNames() if(inherits(instrList, 'instr_nClass')) { oneInstr <- instrList instrList <- nList(instr_nClass)$new() @@ -102,6 +108,8 @@ modelBase_nClass <- nClass( return(logProb) }, simulate = function(instrList) { + if(missing(instrList)) + instrList <- getVarNames() if(inherits(instrList, 'instr_nClass')) { oneInstr <- instrList instrList <- nList(instr_nClass)$new() diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index fd962cc..ebe27d5 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -287,7 +287,7 @@ makeModel_nClass <- function(modelVarInfo, list(OPDEFS = opDefs, # A list of individual elements RPUBLIC = list( - declFunNameToIndex = model$modelDef$declFunNameToIndex, + declFunNameToIndex_ = model$modelDef$declFunNameToIndex, defaultSizes = modelVarInfo$sizes, defaultInits = inits, defaultData = data, diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 4b98345..51a5054 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -1,35 +1,142 @@ # Test code needed for new nimbleModel system. +library(nCompiler) library(nimbleModel) library(testthat) ## TODO: will location and access to predefined nClasses be as described below given they will live ## in `nimbleModel` package? How will dependence on nCompiler work? -## TODO: before I generate the predefined code, need to check on what needs to be done in terms of -## compileInfo for modelBaseClass and declFxnBaseClass. - ## # To update the set of predefined nClasses -## # generate new predef/instr_nC. Move that directly to package code inst/nimbleModel/predef/nodeInstr_nC +## # generate new predef/instr_nC. Move that directly to package code inst/nimbleModel/predef/instr_nC ## nCompile(instr_nClass, control=list(generate_predefined=TRUE)) ## test <- nCompile(instr_nClass) ## # -## # generate new predef/nodeFxnBase_nC. Move to package and add -## # "#include " in the hContent -## # after declaration of newFxnBase_nClass -## nCompile(nodeFxnBase_nClass, control=list(generate_predefined=TRUE)) -## test <- nCompile(nodeFxnBase_nClass) +## # generate new predef/declFunBase_nC. Move to package and add +## # "#include " in the hContent +## # after declaration of declFunBase_nClass +## nCompile(declFunBase_nClass, control=list(generate_predefined=TRUE)) +## test <- nCompile(declFunBase_nClass) ## # ## # generate new predef/modelBase_nC. Move to package and add -## # "#include " to that file, +## # "#include " to that file, ## # after the declaration of modelBase_nClass. ## nCompile(modelBase_nClass, control=list(generate_predefined=TRUE)) ## test <- nCompile(modelBase_nClass) -## #nCompile(nodeFxnBase_nClass, nodeInstr_nClass, control=list(generate_predefined=TRUE)) -## #nCompile(nodeInstr_nClass, calcInstr_nClass, modelBase_nClass, nodeFxnBase_nClass, calcInstrList_nClass, control=list(generate_predefined=TRUE)) +## #nCompile(instr_nClass, modelBase_nClass, declFunBase_nClass, control=list(generate_predefined=TRUE)) ## TODO: revise these tests for instrClass (flattened approach) +test_that("initial tests/examples of nimble model using flattened approach", { + + code <- quote({ + tau ~ dunif(0, 100) + mu ~ dnorm(0,1) + for(i in 1:5) { + y[i] ~ dnorm(mu, var = tau) + } + }) + + inits <- list(tau = 25, mu = 0) + data <- list(y = rnorm(5)) + + ## "Manual" workflow not using `nimbleModel()`. + nm <- modelClass$new(code, inits = inits, data = data) + mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) + m <- mclass$new() + + expect_identical(m$calculate('tau'), dunif(m$tau, 0, 100, log = TRUE)) + + instrList <- makeInstrList(m, 'tau') + expect_identical(m$calculate(instrList), dunif(m$tau, 0, 100, log = TRUE)) + + deps <- m$getDependencies('tau', self = FALSE) + lp <-m$calculate(deps) + expect_identical(m$lifted_sqrt_oPtau_cP, 5) + expect_identical(lp, sum(dnorm(m$y, 0, 5, log = TRUE))) + + ## Check that instrList is in correct order. + instrList <- makeInstrList(m, c('y','lifted_sqrt_oPtau_cP')) + expect_identical(instrList[[1]]$lens, 1) # lifted node first + lp <- m$calculate(instrList) + expect_identical(m$lifted_sqrt_oPtau_cP, 5) + expect_identical(lp, sum(dnorm(m$y, 0, 5, log = TRUE))) + + expect_identical(m$logProb_y, dnorm(m$y, 0, 5, log = TRUE)) + + m$tau <- 1 + lp <- m$calculate(c('y','lifted_sqrt_oPtau_cP')) # Ordering should be done internally. + expect_identical(lp, sum(dnorm(m$y, 0, 1, log = TRUE))) + + expect_identical(m$calculate(), sum(dnorm(m$y, 0, 1, log = TRUE)) + dunif(m$tau, 0, 100, log = TRUE) + dnorm(m$mu, log = TRUE)) + + ## NOTE: `simulate` currently simulates data nodes by default. + set.seed(1) + m$simulate() + expect_identical(m$lifted_sqrt_oPtau_cP, sqrt(m$tau)) + expect_equal(m$mu, -0.326233360706) + m$mu <- 100 + m$tau <- 1 + m$simulate(m$getDependencies('tau', self = FALSE)) + expect_true(all(m$y > 95)) + + ## Use of nimbleModel + mclass <- nimbleModel(code, data = data, inits = inits) + m <- mclass$new() + expect_identical(m$calculate('tau'), dunif(m$tau, 0, 100, log = TRUE)) + + m <- nimbleModel(code, data = data, inits = inits, returnClass = FALSE) + expect_identical(m$calculate('tau'), dunif(m$tau, 0, 100, log = TRUE)) + + ## Override init value when creating model instance. + mclass <- nimbleModel(code, data = data, inits = inits) + m <- mclass$new(inits = list(tau = 7)) + expect_identical(m$tau, 7) + +}) + +test_that("basic creation of list of instr_nClass objects", { + + code <- quote({ + for(i in 1:5) { + mu ~ dnorm(0, 1) + y[i] ~ dnorm(mu, 1) + } + }) + + data <- list(y = rnorm(5)) + + m <- nimbleModel(code, data = data, returnClass = FALSE) + + instr0 <- makeInstrList(m, 'mu')[[1]] + expect_identical(instr0$lens, 1) + expect_identical(length(instr0$values), 0) + expect_identical(instr0$index_types, 0) + expect_identical(instr0$type, 0) + + instr1 <- makeInstrList(m, 'y[3:4]')[[1]] + expect_identical(instr1$lens, 2) + expect_identical(instr1$values[[1]], 2) # offset + expect_identical(instr1$index_types, 1) + expect_identical(instr1$type, 1) + + instr2 <- makeInstrList(m, c('y[c(2,5)]'))[[1]] + expect_identical(instr2$lens, 2) + expect_identical(instr2$values[[1]], c(2,5)) + expect_identical(instr2$index_types, 2) + expect_identical(instr2$type, 2) + + instr2 <- makeInstrList(m, varRangeClass$new(list(newIndexRange(matrix(c(2,5), ncol=1))), varName='y'))[[1]] + expect_identical(instr2$lens, 2) + expect_identical(instr2$values[[1]], c(2,5)) + expect_identical(instr2$index_types, 2) + expect_identical(instr2$type, 2) + + ## TODO: flesh this out with multiple index cases. +}) + +## TODO: modify tests below in light of flattened approach. + test_that("nimble model prototype works", { nodeVarInfo <- list(list(name = "x", nDim = 1), list(name = "mu", nDim = 1), list(name = "sd", nDim = 0)) @@ -201,62 +308,3 @@ if(FALSE) { obj$calculate(calcInstrList) } -######## - -## CJP experimentation with nimbleModel, modelClass stuff. - -library(nimbleModel);library(nCompiler) - -code <- quote({ - sd ~ dunif(0, 10) - for(i in 1:5) { - # z[i] <- x[i+1] + 10 - y[i] ~ dnorm(x[i+1], sd = sd) - } -}) - -inits <- list(sd = 1.5) -data <- list(y = rnorm(5)) -nm <- modelClass$new(code, inits = inits, data = data) -mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) - -cmclass <- nCompile(mclass) - -# .debugModelInit <- TRUE -m <- mclass$new(inits=list(sd=5, x = rnorm(6))) - -m$calculate('sd') -instrList <- makeInstrList(m, 'sd') -m$calculate(instrList) -instrList <- makeInstrList(m, 'y') -m$calculate(instrList) - -instrList <- makeInstrList(m, c('y','sd')) # ordering should be done internally -m$calculate(instrList) - -m$calculate(c('y','sd')) # ordering should be done internally - -m$y -m$simulate('y') -m$y - -# cr <- m$modelDef$calcRules[['y']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['y']]$rules[[1]]$apply('y')) -# cr <- m$modelDef$calcRules[['sd']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['sd']]$rules[[1]]$apply('sd')) - -## Direct access to decl calculation works. -out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calc_one(0) -out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calc_0(instrList[[1]]) -out = m$private$Cpublic_obj$decl_1$private$Cpublic_obj$calculate(instrList[[1]]) - -mclass <- nimbleModel(code, data = data, inits = inits) -m <- mclass$new(inits=list(sd=5, x = rnorm(6))) -m$calculate(c('y','sd')) - -m <- nimbleModel(code, data = data, inits = inits, returnClass = FALSE) - -m$calculate(m$getDependencies('sd')) -m$calculate(m$getDependencies('sd', self = FALSE)) - - -## Try out compilation; see nCompiler's test-nimbleModel.R. - From 4999fd49664732e1cea6d024268a98dd87c1a942 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Thu, 28 May 2026 12:33:56 -0700 Subject: [PATCH 20/32] Make minor adjustments to nimbleModel tests. --- nimbleModel/tests/testthat/test-nimbleModel.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 51a5054..5bf939f 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -66,9 +66,9 @@ test_that("initial tests/examples of nimble model using flattened approach", { m$tau <- 1 lp <- m$calculate(c('y','lifted_sqrt_oPtau_cP')) # Ordering should be done internally. - expect_identical(lp, sum(dnorm(m$y, 0, 1, log = TRUE))) + expect_equal(lp, sum(dnorm(m$y, 0, 1, log = TRUE))) # Why not identical? - expect_identical(m$calculate(), sum(dnorm(m$y, 0, 1, log = TRUE)) + dunif(m$tau, 0, 100, log = TRUE) + dnorm(m$mu, log = TRUE)) + expect_equal(m$calculate(), sum(dnorm(m$y, 0, 1, log = TRUE)) + dunif(m$tau, 0, 100, log = TRUE) + dnorm(m$mu, log = TRUE)) ## NOTE: `simulate` currently simulates data nodes by default. set.seed(1) @@ -110,7 +110,7 @@ test_that("basic creation of list of instr_nClass objects", { instr0 <- makeInstrList(m, 'mu')[[1]] expect_identical(instr0$lens, 1) - expect_identical(length(instr0$values), 0) + expect_identical(length(instr0$values), 0L) expect_identical(instr0$index_types, 0) expect_identical(instr0$type, 0) From 780b2a67c621e1235307ff17ab5bb74372e091f0 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Fri, 29 May 2026 09:40:38 -0700 Subject: [PATCH 21/32] Add getLogProb, calculateDiff. Rearrange creation of instrList input to decl functions. --- nimbleModel/R/declFunBaseClass.R | 94 +++++++++++++++++++ nimbleModel/R/instructions.R | 53 +++++++---- nimbleModel/R/modelBaseClass.R | 91 ++++++++++++------ nimbleModel/tests/testthat/test-nimbleModel.R | 20 ++-- 4 files changed, 208 insertions(+), 50 deletions(-) diff --git a/nimbleModel/R/declFunBaseClass.R b/nimbleModel/R/declFunBaseClass.R index e0710b7..cd46a58 100644 --- a/nimbleModel/R/declFunBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -8,6 +8,7 @@ declFunBase_nClass <- nClass( function() {return(TRUE); returnType(logical())}, compileInfo = list(virtual=TRUE) ), + calculate = nFunction( name = "calculate", fun = function(instr = 'instr_nClass') { @@ -54,6 +55,52 @@ declFunBase_nClass <- nClass( }, returnType = 'numericScalar' ), + calculateDiff = nFunction( + name = "calculateDiff", + fun = function(instr = 'instr_nClass') { + ## TODO: how embed determination of vec and parallel cases here? + if(instr$type == 0) return(calcDiff_0(instr)) + if(instr$type == 1) return(calcDiff_1_seq(instr)) + if(instr$type == 2) return(calcDiff_1_mat(instr)) + if(instr$type == 3) return(calcDiff_1_matp(instr)) + return(0) ## Need to error trap/warn if unhandled type requested + }, returnType = 'numericScalar', + compileInfo = list(virtual=TRUE) + ), + calcDiff_0 = nFunction( + name = 'calcDiff_0', + function(instr = 'instr_nClass') { + return(calcDiff_one(0)) ## calcDiff_one will always has `idx` as arg? + }, returnType = 'numericScalar' + ), + calcDiff_1_seq = nFunction( + name = 'calcDiff_1_seq', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + calcDiff_one(instr$values[[1]][1]+i) + return(logProb) + }, returnType = 'numericScalar' + ), + calcDiff_1_mat = nFunction( + name = 'calcDiff_1_mat', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + calcDiff_one(instr$values[[1]][i]) + return(logProb) + }, returnType = 'numericScalar' + ), + calcDiff_1_matp = nFunction( + name = 'calcDiff_1_mat', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + calcDiff_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + return(logProb) + }, returnType = 'numericScalar' + ), + simulate = nFunction( name = "simulate", fun = function(instr = 'instr_nClass') { @@ -91,7 +138,54 @@ declFunBase_nClass <- nClass( for(i in 1:instr$lens[1]) sim_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? } + ), + + getLogProb = nFunction( + name = "getLogProb", + fun = function(instr = 'instr_nClass') { + ## TODO: how embed determination of vec and parallel cases here? + if(instr$type == 0) return(getLogProb_0(instr)) + if(instr$type == 1) return(getLogProb_1_seq(instr)) + if(instr$type == 2) return(getLogProb_1_mat(instr)) + if(instr$type == 3) return(getLogProb_1_matp(instr)) + return(0) ## Need to error trap/warn if unhandled type requested + }, returnType = 'numericScalar', + compileInfo = list(virtual=TRUE) + ), + getLogProb_0 = nFunction( + name = 'getLogProb_0', + function(instr = 'instr_nClass') { + return(getLogProb_one(0)) ## getLogProb_one will always has `idx` as arg? + }, returnType = 'numericScalar' + ), + getLogProb_1_seq = nFunction( + name = 'getLogProb_1_seq', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + getLogProb_one(instr$values[[1]][1]+i) + return(logProb) + }, returnType = 'numericScalar' + ), + getLogProb_1_mat = nFunction( + name = 'getLogProb_1_mat', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + getLogProb_one(instr$values[[1]][i]) + return(logProb) + }, returnType = 'numericScalar' + ), + getLogProb_1_matp = nFunction( + name = 'getLogProb_1_mat', + function(instr = 'instr_nClass') { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + getLogProb_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + return(logProb) + }, returnType = 'numericScalar' ) + ), ## We haven't dealt with ensuring a virtual destructor when any method is virtual ## For now I did it manually by editing the .h and .cpp diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index f1a51a0..5938244 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -83,16 +83,37 @@ determineInstrType <- function(instr, use_vec = FALSE) { return(type2itype[[type]]) } +## TODO: document this since it may be user-facing. #' @export -makeInstrList <- function(model, varRanges, use_vec = FALSE) { - if(missing(varRanges)) - varRanges <- model$getVarNames() - ## This works with a char vector of "nodes" or a list of (or single) varRanges - if(is(varRanges, 'varRangeClass')) varRanges <- list(varRanges) +makeInstrList <- function(model, input, use_vec = FALSE) { + ## `model` simply must contain `modelDef`, so it can be a modelClass or modelBase_nClass object. + ## This works with: + ## (1) a char vector of "nodes" + ## (2) a list of (or single) varRanges + ## (3) an nList of (or single) instr_nClass objects (assumed to be in sort order) + ## (4) an R list of instr_nClass objects (not assumed to be in sort order) + if(is(input, 'nList')) + if(!inherits(input[[1]], 'instr_nClass')) { + stop("nList input to `makeInstrList` should contain `instr_nClass` objects") + } else return(input) # Idempotent case. + if(is(input, 'instr_nClass')) + input <- list(input) + if(is.list(input) && all(sapply(input, function(x) inherits(x, 'instr_nClass')))) { + ## Create sort-ordered nList. + instrList <- nList(instr_nClass)$new() + numInstrs <- length(input) + instrList$setLength(numInstrs) + ord <- order(unlist(lapply(input, function(x) x$sortID))) + for(i in 1:numInstrs) + instrList[[i]] <- input[[ord[i]]] + return(instrList) + } + ## At this point we presumably are working with varRange(s). + if(is(input, 'varRangeClass')) input <- list(input) ## First apply calcRule to get overlap between input and the rule. ## Then make the calcRange to convert to loop indexing. ## Note that `calcRule$apply` handles converting char to varRange and handling full variable extent. - ranges <- unlist(lapply(varRanges, function(vr) + ranges <- unlist(lapply(input, function(vr) lapply(model$modelDef$calcRules[[nimbleModel:::getVarName(vr)]]$rules, function(rule) rule$makeCalcRange(rule$apply(vr)) ))) @@ -109,20 +130,20 @@ instr_nClass <- nClass( classname = "instr_nClass", Rpublic = list( initialize = function(calcRange) { - instrList <- range2instr(calcRange) # This processing could simply be included here in `initialize`. - self$lens <- instrList$lens - self$index_types <- instrList$index_types - self$dim <- instrList$dim - self$dims <- instrList$dims - self$slots <- instrList$slots + instr <- range2instr(calcRange) # This processing could simply be included here in `initialize`. + self$lens <- instr$lens + self$index_types <- instr$index_types + self$dim <- instr$dim + self$dims <- instr$dims + self$slots <- instr$slots self$values <- nList(integerVector)$new() self$values$setLength(length(self$dims)) if(self$dim) for(i in 1:length(self$dims)) - self$values[[i]] <- instrList$values[[i]] - self$type <- instrList$type # Use integer for compilation (would char be ok?). - self$sortID <- instrList$sortID - self$declID <- instrList$declID + self$values[[i]] <- instr$values[[i]] + self$type <- instr$type # Use integer for compilation (would char be ok?). + self$sortID <- instr$sortID + self$declID <- instr$declID }), Cpublic = list( lens = 'integerVector', diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index abc6d23..5357985 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -85,19 +85,11 @@ modelBase_nClass <- nClass( nimbleModel::getNodes(modelDef, nodes, stochOnly, determOnly, includeData, dataOnly, includePredictive, predictiveOnly, includeRHSonly, topOnly, latentOnly, endOnly) - }, - calculate = function(instrList) { - if(missing(instrList)) - instrList <- getVarNames() - if(inherits(instrList, 'instr_nClass')) { - oneInstr <- instrList - instrList <- nList(instr_nClass)$new() - instrList$setLength(1) - instrList[[1]] <- oneInstr - } - if(!((inherits(instrList, 'nList') || is.list(instrList)) && inherits(instrList[[1]], 'instr_nClass'))) - instrList <- makeInstrList(self, instrList) - ## Assume instrList is ordered (it is done `makeInstrList`). + }, + calculate = function(input) { + if(missing(input)) + input <- getVarNames() + instrList <- makeInstrList(self,input) if(isCompiled()) return(calculate_impl(instrList)) logProb <- 0 @@ -106,23 +98,40 @@ modelBase_nClass <- nClass( } return(logProb) }, - simulate = function(instrList) { - if(missing(instrList)) - instrList <- getVarNames() - if(inherits(instrList, 'instr_nClass')) { - oneInstr <- instrList - instrList <- nList(instr_nClass)$new() - instrList$setLength(1) - instrList[[1]] <- oneInstr + calculateDiff = function(input) { + if(missing(input)) + input <- getVarNames() + instrList <- makeInstrList(self, input) + if(isCompiled()) + return(calculateDiff_impl(instrList)) + logProb <- 0 + for(i in 1:length(instrList)) { + logProb <- logProb + declFunList[[instrList[[i]]$declID]]$calculateDiff(instrList[[i]]) } - if(!((inherits(instrList, 'nList') || is.list(instrList)) && inherits(instrList[[1]], 'instr_nClass'))) - instrList <- makeInstrList(self, instrList) - ## Assume instrList is ordered (it is done `makeInstrList`). + return(logProb) + }, + simulate = function(input) { + if(missing(input)) + input <- getVarNames() + instrList <- makeInstrList(self, input) + if(isCompiled()) { + simulate_impl(instrList) + } else + for(i in 1:length(instrList)) { + declFunList[[instrList[[i]]$declID]]$simulate(instrList[[i]]) + } + }, + getLogProb = function(input) { + if(missing(input)) + input <- getVarNames() + instrList <- makeInstrList(self, input) if(isCompiled()) - return(simulate_impl(instrList)) + return(getLogProb_impl(instrList)) + logProb <- 0 for(i in 1:length(instrList)) { - declFunList[[instrList[[i]]$declID]]$simulate(instrList[[i]]) + logProb <- logProb + declFunList[[instrList[[i]]$declID]]$getLogProb(instrList[[i]]) } + return(logProb) } ), Cpublic = list( @@ -149,19 +158,45 @@ modelBase_nClass <- nClass( virtual=TRUE ) ), + calculateDiff_impl = nFunction( + name = "calculateDiff_impl", + function(instrList) { + cat("Uncompiled `calculateDiff_impl` should never be called.\n") + return(0) + }, + returnType = 'numericScalar', + compileInfo = list( + C_fun = function(instrList = 'nList(instr_nClass)') { + ## NOTE: instrList input will be ordered. + cppLiteral('modelClass_::calculateDiff(instrList);') + }, + virtual=TRUE + ) + ), simulate_impl = nFunction( name = "simulate_impl", function(instrList) { cat("Uncompiled `simulate_impl` should never be called.\n") - return(0) }, - returnType = 'numericScalar', compileInfo = list( C_fun = function(instrList = 'nList(instr_nClass)') { cppLiteral('modelClass_::simulate(instrList);') }, virtual=TRUE ) + ), + getLogProb_impl = nFunction( + name = "getLogProb_impl", + function(instrList) { + cat("Uncompiled `getLogProb_impl` should never be called.\n") + }, + returnType = 'numericScalar', + compileInfo = list( + C_fun = function(instrList = 'nList(instr_nClass)') { + cppLiteral('modelClass_::getLogProb(instrList);') + }, + virtual=TRUE + ) ) ), ## See comment above about needing to ensure a virtual destructor diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 5bf939f..4889788 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -45,22 +45,28 @@ test_that("initial tests/examples of nimble model using flattened approach", { mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) m <- mclass$new() - expect_identical(m$calculate('tau'), dunif(m$tau, 0, 100, log = TRUE)) + lp_tau <- dunif(m$tau, 0, 100, log = TRUE) + expect_identical(m$calculate('tau'), lp_tau) + expect_identical(m$getLogProb('tau'), lp_tau) instrList <- makeInstrList(m, 'tau') - expect_identical(m$calculate(instrList), dunif(m$tau, 0, 100, log = TRUE)) + expect_identical(m$calculate(instrList), lp_tau) + expect_identical(m$getLogProb(instrList), lp_tau) deps <- m$getDependencies('tau', self = FALSE) - lp <-m$calculate(deps) + lp_y <- sum(dnorm(m$y, 0, 5, log = TRUE)) + lp <- m$calculate(deps) expect_identical(m$lifted_sqrt_oPtau_cP, 5) - expect_identical(lp, sum(dnorm(m$y, 0, 5, log = TRUE))) + expect_equal(lp, lp_y) + expect_identical(m$getLogProb('y'), lp) ## Check that instrList is in correct order. instrList <- makeInstrList(m, c('y','lifted_sqrt_oPtau_cP')) expect_identical(instrList[[1]]$lens, 1) # lifted node first lp <- m$calculate(instrList) expect_identical(m$lifted_sqrt_oPtau_cP, 5) - expect_identical(lp, sum(dnorm(m$y, 0, 5, log = TRUE))) + expect_equal(lp, lp_y) + expect_identical(m$getLogProb(c('y','lifted_sqrt_oPtau_cP')), lp_y) expect_identical(m$logProb_y, dnorm(m$y, 0, 5, log = TRUE)) @@ -68,7 +74,9 @@ test_that("initial tests/examples of nimble model using flattened approach", { lp <- m$calculate(c('y','lifted_sqrt_oPtau_cP')) # Ordering should be done internally. expect_equal(lp, sum(dnorm(m$y, 0, 1, log = TRUE))) # Why not identical? - expect_equal(m$calculate(), sum(dnorm(m$y, 0, 1, log = TRUE)) + dunif(m$tau, 0, 100, log = TRUE) + dnorm(m$mu, log = TRUE)) + lp <- sum(dnorm(m$y, 0, 1, log = TRUE)) + dunif(m$tau, 0, 100, log = TRUE) + dnorm(m$mu, log = TRUE) + expect_equal(m$calculate(), lp) + expect_equal(m$getLogProb(), lp) ## NOTE: `simulate` currently simulates data nodes by default. set.seed(1) From 77c8cc056adcee92a95a36fc88d45595f37ddaee Mon Sep 17 00:00:00 2001 From: perrydv Date: Fri, 29 May 2026 13:51:53 -0700 Subject: [PATCH 22/32] get predefineds working and generated --- nimbleModel/.DS_Store | Bin 0 -> 6148 bytes nimbleModel/R/declFunBaseClass.R | 327 +++++++++--------- nimbleModel/R/instructions.R | 9 +- nimbleModel/R/modelBaseClass.R | 158 ++++----- .../declFunBase_nClass_copyFiles.txt | 0 .../declFunBase_nClass_cppContent.cpp | 57 +++ .../declFunBase_nClass_filebase.txt | 1 + .../declFunBase_nClass_hContent.h | 24 ++ .../declFunBase_nClass_manifest.txt | 7 + .../declFunBase_nClass_post_cpp_compiler.txt | 0 .../declFunBase_nClass_preamble.cpp | 5 + .../instr_nClass/instr_nClass_copyFiles.txt | 0 .../instr_nClass/instr_nClass_cppContent.cpp | 53 +++ .../instr_nClass/instr_nClass_filebase.txt | 1 + .../instr_nClass/instr_nClass_hContent.h | 32 ++ .../instr_nClass/instr_nClass_manifest.txt | 7 + .../instr_nClass_post_cpp_compiler.txt | 0 .../instr_nClass/instr_nClass_preamble.cpp | 5 + .../modelBase_nClass_copyFiles.txt | 0 .../modelBase_nClass_cppContent.cpp | 52 +++ .../modelBase_nClass_filebase.txt | 1 + .../modelBase_nC/modelBase_nClass_hContent.h | 26 ++ .../modelBase_nClass_manifest.txt | 7 + .../modelBase_nClass_post_cpp_compiler.txt | 0 .../modelBase_nClass_preamble.cpp | 5 + nimbleModel/tests/testthat/test-nimbleModel.R | 23 +- 26 files changed, 549 insertions(+), 251 deletions(-) create mode 100644 nimbleModel/.DS_Store create mode 100644 nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_copyFiles.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_cppContent.cpp create mode 100644 nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_filebase.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_hContent.h create mode 100644 nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_manifest.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_preamble.cpp create mode 100644 nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_copyFiles.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp create mode 100644 nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_filebase.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h create mode 100644 nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_manifest.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_post_cpp_compiler.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_preamble.cpp create mode 100644 nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_copyFiles.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_cppContent.cpp create mode 100644 nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_filebase.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_hContent.h create mode 100644 nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_manifest.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt create mode 100644 nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_preamble.cpp diff --git a/nimbleModel/.DS_Store b/nimbleModel/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..59c8ece918bfacf0a87972e5a2cef9f6a7bd715c GIT binary patch literal 6148 zcmeHKK~BR!474GKNL+dY4oLfj{$Q!X3;F?6DgjbMDi!Xz@r=Hquiz#8gR#9-twNBv zAc4k`ce1u8o6I4OMMP&W%c;mjL~6L9yxKA}%bO4Eq(my9+C5hH)A?Q3t_PLl0pnKk zC{MDH=P&sCT-!CxV%05BUtgW?wwLd3*N5D;TYj5gKm7RF#-ExQDnJFO02QDDe^&wY zY_s|-kSi6S0#snHfPEhl+%OmH1O3y1#YX_3{l>fD+Gh!1vH&m_>;n;jX;6Vd)iPpe z&=F6iE*I4+yU7tMiOsQ?u?R^T+Y6YKvs@R9ldn8Y0wpaTC& z0j-*OGs7#D-a2?W>$M4f3;#6KdN~$v#XxVx*jOvRIH*f@jeIWH2Ra>brvv#TV7kz# Iz;7t<0b%bbJ^%m! literal 0 HcmV?d00001 diff --git a/nimbleModel/R/declFunBaseClass.R b/nimbleModel/R/declFunBaseClass.R index cd46a58..09e4233 100644 --- a/nimbleModel/R/declFunBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -14,9 +14,9 @@ declFunBase_nClass <- nClass( fun = function(instr = 'instr_nClass') { ## TODO: how embed determination of vec and parallel cases here? if(instr$type == 0) return(calc_0(instr)) - if(instr$type == 1) return(calc_1_seq(instr)) - if(instr$type == 2) return(calc_1_mat(instr)) - if(instr$type == 3) return(calc_1_matp(instr)) + # if(instr$type == 1) return(calc_1_seq(instr)) + # if(instr$type == 2) return(calc_1_mat(instr)) + # if(instr$type == 3) return(calc_1_matp(instr)) return(0) ## Need to error trap/warn if unhandled type requested }, returnType = 'numericScalar', compileInfo = list(virtual=TRUE) @@ -25,166 +25,173 @@ declFunBase_nClass <- nClass( name = 'calc_0', function(instr = 'instr_nClass') { return(calc_one(0)) ## calc_one will always has `idx` as arg? - }, returnType = 'numericScalar' - ), - calc_1_seq = nFunction( - name = 'calc_1_seq', - function(instr = 'instr_nClass') { - logProb = 0 - for(i in 1:instr$lens[1]) - logProb <- logProb + calc_one(instr$values[[1]][1]+i) - return(logProb) - }, returnType = 'numericScalar' - ), - calc_1_mat = nFunction( - name = 'calc_1_mat', - function(instr = 'instr_nClass') { - logProb = 0 - for(i in 1:instr$lens[1]) - logProb <- logProb + calc_one(instr$values[[1]][i]) - return(logProb) - }, returnType = 'numericScalar' - ), - calc_1_matp = nFunction( - name = 'calc_1_mat', - function(instr = 'instr_nClass') { - logProb = 0 - for(i in 1:instr$lens[1]) - logProb <- logProb + calc_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? - return(logProb) - }, returnType = 'numericScalar' - ), + }, + returnType = 'numericScalar', + compileInfo = list( + C_fun = function(instr = 'instr_nClass') { + cppLiteral('Rprintf("declFunBase_nClass calc_0 (should not see this)\\n");'); return(0) + }, + virtual=TRUE + ) + )#, + # calc_1_seq = nFunction( + # name = 'calc_1_seq', + # function(instr = 'instr_nClass') { + # logProb = 0 + # for(i in 1:instr$lens[1]) + # logProb <- logProb + calc_one(instr$values[[1]][1]+i) + # return(logProb) + # }, returnType = 'numericScalar' + # ), + # calc_1_mat = nFunction( + # name = 'calc_1_mat', + # function(instr = 'instr_nClass') { + # logProb = 0 + # for(i in 1:instr$lens[1]) + # logProb <- logProb + calc_one(instr$values[[1]][i]) + # return(logProb) + # }, returnType = 'numericScalar' + # ), + # calc_1_matp = nFunction( + # name = 'calc_1_mat', + # function(instr = 'instr_nClass') { + # logProb = 0 + # for(i in 1:instr$lens[1]) + # logProb <- logProb + calc_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + # return(logProb) + # }, returnType = 'numericScalar' + # ), - calculateDiff = nFunction( - name = "calculateDiff", - fun = function(instr = 'instr_nClass') { - ## TODO: how embed determination of vec and parallel cases here? - if(instr$type == 0) return(calcDiff_0(instr)) - if(instr$type == 1) return(calcDiff_1_seq(instr)) - if(instr$type == 2) return(calcDiff_1_mat(instr)) - if(instr$type == 3) return(calcDiff_1_matp(instr)) - return(0) ## Need to error trap/warn if unhandled type requested - }, returnType = 'numericScalar', - compileInfo = list(virtual=TRUE) - ), - calcDiff_0 = nFunction( - name = 'calcDiff_0', - function(instr = 'instr_nClass') { - return(calcDiff_one(0)) ## calcDiff_one will always has `idx` as arg? - }, returnType = 'numericScalar' - ), - calcDiff_1_seq = nFunction( - name = 'calcDiff_1_seq', - function(instr = 'instr_nClass') { - logProb = 0 - for(i in 1:instr$lens[1]) - logProb <- logProb + calcDiff_one(instr$values[[1]][1]+i) - return(logProb) - }, returnType = 'numericScalar' - ), - calcDiff_1_mat = nFunction( - name = 'calcDiff_1_mat', - function(instr = 'instr_nClass') { - logProb = 0 - for(i in 1:instr$lens[1]) - logProb <- logProb + calcDiff_one(instr$values[[1]][i]) - return(logProb) - }, returnType = 'numericScalar' - ), - calcDiff_1_matp = nFunction( - name = 'calcDiff_1_mat', - function(instr = 'instr_nClass') { - logProb = 0 - for(i in 1:instr$lens[1]) - logProb <- logProb + calcDiff_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? - return(logProb) - }, returnType = 'numericScalar' - ), + # calculateDiff = nFunction( + # name = "calculateDiff", + # fun = function(instr = 'instr_nClass') { + # ## TODO: how embed determination of vec and parallel cases here? + # if(instr$type == 0) return(calcDiff_0(instr)) + # if(instr$type == 1) return(calcDiff_1_seq(instr)) + # if(instr$type == 2) return(calcDiff_1_mat(instr)) + # if(instr$type == 3) return(calcDiff_1_matp(instr)) + # return(0) ## Need to error trap/warn if unhandled type requested + # }, returnType = 'numericScalar', + # compileInfo = list(virtual=TRUE) + # ), + # calcDiff_0 = nFunction( + # name = 'calcDiff_0', + # function(instr = 'instr_nClass') { + # return(calcDiff_one(0)) ## calcDiff_one will always has `idx` as arg? + # }, returnType = 'numericScalar' + # ), + # calcDiff_1_seq = nFunction( + # name = 'calcDiff_1_seq', + # function(instr = 'instr_nClass') { + # logProb = 0 + # for(i in 1:instr$lens[1]) + # logProb <- logProb + calcDiff_one(instr$values[[1]][1]+i) + # return(logProb) + # }, returnType = 'numericScalar' + # ), + # calcDiff_1_mat = nFunction( + # name = 'calcDiff_1_mat', + # function(instr = 'instr_nClass') { + # logProb = 0 + # for(i in 1:instr$lens[1]) + # logProb <- logProb + calcDiff_one(instr$values[[1]][i]) + # return(logProb) + # }, returnType = 'numericScalar' + # ), + # calcDiff_1_matp = nFunction( + # name = 'calcDiff_1_mat', + # function(instr = 'instr_nClass') { + # logProb = 0 + # for(i in 1:instr$lens[1]) + # logProb <- logProb + calcDiff_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + # return(logProb) + # }, returnType = 'numericScalar' + # ), - simulate = nFunction( - name = "simulate", - fun = function(instr = 'instr_nClass') { - ## TODO: how embed determination of vec and parallel cases here? - if(instr$type == 0) sim_0(instr) - if(instr$type == 1) sim_1_seq(instr) - if(instr$type == 2) sim_1_mat(instr) - if(instr$type == 3) sim_1_matp(instr) - }, - compileInfo = list(virtual=TRUE) - ), - sim_0 = nFunction( - name = 'sim_0', - function(instr = 'instr_nClass') { - sim_one(0) ## sim_one will always has `idx` as arg? - } - ), - sim_1_seq = nFunction( - name = 'sim_1_seq', - function(instr = 'instr_nClass') { - for(i in 1:instr$lens[1]) - sim_one(instr$values[[1]][1]+i) - } - ), - sim_1_mat = nFunction( - name = 'sim_1_mat', - function(instr = 'instr_nClass') { - for(i in 1:instr$lens[1]) - sim_one(instr$values[[1]][i]) - } - ), - sim_1_matp = nFunction( - name = 'sim_1_mat', - function(instr = 'instr_nClass') { - for(i in 1:instr$lens[1]) - sim_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? - } - ), + # simulate = nFunction( + # name = "simulate", + # fun = function(instr = 'instr_nClass') { + # ## TODO: how embed determination of vec and parallel cases here? + # if(instr$type == 0) sim_0(instr) + # if(instr$type == 1) sim_1_seq(instr) + # if(instr$type == 2) sim_1_mat(instr) + # if(instr$type == 3) sim_1_matp(instr) + # }, + # compileInfo = list(virtual=TRUE) + # ), + # sim_0 = nFunction( + # name = 'sim_0', + # function(instr = 'instr_nClass') { + # sim_one(0) ## sim_one will always has `idx` as arg? + # } + # ), + # sim_1_seq = nFunction( + # name = 'sim_1_seq', + # function(instr = 'instr_nClass') { + # for(i in 1:instr$lens[1]) + # sim_one(instr$values[[1]][1]+i) + # } + # ), + # sim_1_mat = nFunction( + # name = 'sim_1_mat', + # function(instr = 'instr_nClass') { + # for(i in 1:instr$lens[1]) + # sim_one(instr$values[[1]][i]) + # } + # ), + # sim_1_matp = nFunction( + # name = 'sim_1_mat', + # function(instr = 'instr_nClass') { + # for(i in 1:instr$lens[1]) + # sim_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + # } + # ), - getLogProb = nFunction( - name = "getLogProb", - fun = function(instr = 'instr_nClass') { - ## TODO: how embed determination of vec and parallel cases here? - if(instr$type == 0) return(getLogProb_0(instr)) - if(instr$type == 1) return(getLogProb_1_seq(instr)) - if(instr$type == 2) return(getLogProb_1_mat(instr)) - if(instr$type == 3) return(getLogProb_1_matp(instr)) - return(0) ## Need to error trap/warn if unhandled type requested - }, returnType = 'numericScalar', - compileInfo = list(virtual=TRUE) - ), - getLogProb_0 = nFunction( - name = 'getLogProb_0', - function(instr = 'instr_nClass') { - return(getLogProb_one(0)) ## getLogProb_one will always has `idx` as arg? - }, returnType = 'numericScalar' - ), - getLogProb_1_seq = nFunction( - name = 'getLogProb_1_seq', - function(instr = 'instr_nClass') { - logProb = 0 - for(i in 1:instr$lens[1]) - logProb <- logProb + getLogProb_one(instr$values[[1]][1]+i) - return(logProb) - }, returnType = 'numericScalar' - ), - getLogProb_1_mat = nFunction( - name = 'getLogProb_1_mat', - function(instr = 'instr_nClass') { - logProb = 0 - for(i in 1:instr$lens[1]) - logProb <- logProb + getLogProb_one(instr$values[[1]][i]) - return(logProb) - }, returnType = 'numericScalar' - ), - getLogProb_1_matp = nFunction( - name = 'getLogProb_1_mat', - function(instr = 'instr_nClass') { - logProb = 0 - for(i in 1:instr$lens[1]) - logProb <- logProb + getLogProb_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? - return(logProb) - }, returnType = 'numericScalar' - ) + # getLogProb = nFunction( + # name = "getLogProb", + # fun = function(instr = 'instr_nClass') { + # ## TODO: how embed determination of vec and parallel cases here? + # if(instr$type == 0) return(getLogProb_0(instr)) + # if(instr$type == 1) return(getLogProb_1_seq(instr)) + # if(instr$type == 2) return(getLogProb_1_mat(instr)) + # if(instr$type == 3) return(getLogProb_1_matp(instr)) + # return(0) ## Need to error trap/warn if unhandled type requested + # }, returnType = 'numericScalar', + # compileInfo = list(virtual=TRUE) + # ), + # getLogProb_0 = nFunction( + # name = 'getLogProb_0', + # function(instr = 'instr_nClass') { + # return(getLogProb_one(0)) ## getLogProb_one will always has `idx` as arg? + # }, returnType = 'numericScalar' + # ), + # getLogProb_1_seq = nFunction( + # name = 'getLogProb_1_seq', + # function(instr = 'instr_nClass') { + # logProb = 0 + # for(i in 1:instr$lens[1]) + # logProb <- logProb + getLogProb_one(instr$values[[1]][1]+i) + # return(logProb) + # }, returnType = 'numericScalar' + # ), + # getLogProb_1_mat = nFunction( + # name = 'getLogProb_1_mat', + # function(instr = 'instr_nClass') { + # logProb = 0 + # for(i in 1:instr$lens[1]) + # logProb <- logProb + getLogProb_one(instr$values[[1]][i]) + # return(logProb) + # }, returnType = 'numericScalar' + # ), + # getLogProb_1_matp = nFunction( + # name = 'getLogProb_1_mat', + # function(instr = 'instr_nClass') { + # logProb = 0 + # for(i in 1:instr$lens[1]) + # logProb <- logProb + getLogProb_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + # return(logProb) + # }, returnType = 'numericScalar' + # ) ), ## We haven't dealt with ensuring a virtual destructor when any method is virtual diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index 5938244..0c7faa7 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -158,10 +158,11 @@ instr_nClass <- nClass( ), predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("instr_nClass")), compileInfo = list(interface = "full", - createFromR = FALSE, - exportName = "instr_nClass_new", - packageNames = c(uncompiled="instr_nClass_R", compiled="instr_nClass") - ) + createFromR = TRUE, + exportName = "instr_nClass_new", + needed_units = list("nList(integerVector)"), + packageNames = c(uncompiled="instr_nClass_R", compiled="instr_nClass") + ) ) diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 5357985..a40986e 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -97,42 +97,42 @@ modelBase_nClass <- nClass( logProb <- logProb + declFunList[[instrList[[i]]$declID]]$calculate(instrList[[i]]) } return(logProb) - }, - calculateDiff = function(input) { - if(missing(input)) - input <- getVarNames() - instrList <- makeInstrList(self, input) - if(isCompiled()) - return(calculateDiff_impl(instrList)) - logProb <- 0 - for(i in 1:length(instrList)) { - logProb <- logProb + declFunList[[instrList[[i]]$declID]]$calculateDiff(instrList[[i]]) - } - return(logProb) - }, - simulate = function(input) { - if(missing(input)) - input <- getVarNames() - instrList <- makeInstrList(self, input) - if(isCompiled()) { - simulate_impl(instrList) - } else - for(i in 1:length(instrList)) { - declFunList[[instrList[[i]]$declID]]$simulate(instrList[[i]]) - } - }, - getLogProb = function(input) { - if(missing(input)) - input <- getVarNames() - instrList <- makeInstrList(self, input) - if(isCompiled()) - return(getLogProb_impl(instrList)) - logProb <- 0 - for(i in 1:length(instrList)) { - logProb <- logProb + declFunList[[instrList[[i]]$declID]]$getLogProb(instrList[[i]]) - } - return(logProb) - } + }#, + # calculateDiff = function(input) { + # if(missing(input)) + # input <- getVarNames() + # instrList <- makeInstrList(self, input) + # if(isCompiled()) + # return(calculateDiff_impl(instrList)) + # logProb <- 0 + # for(i in 1:length(instrList)) { + # logProb <- logProb + declFunList[[instrList[[i]]$declID]]$calculateDiff(instrList[[i]]) + # } + # return(logProb) + # }, + # simulate = function(input) { + # if(missing(input)) + # input <- getVarNames() + # instrList <- makeInstrList(self, input) + # if(isCompiled()) { + # simulate_impl(instrList) + # } else + # for(i in 1:length(instrList)) { + # declFunList[[instrList[[i]]$declID]]$simulate(instrList[[i]]) + # } + # }, + # getLogProb = function(input) { + # if(missing(input)) + # input <- getVarNames() + # instrList <- makeInstrList(self, input) + # if(isCompiled()) + # return(getLogProb_impl(instrList)) + # logProb <- 0 + # for(i in 1:length(instrList)) { + # logProb <- logProb + declFunList[[instrList[[i]]$declID]]$getLogProb(instrList[[i]]) + # } + # return(logProb) + # } ), Cpublic = list( ## TODO: using 'RcppObject' was resulting in a symbolTBD error - probably nCompiler issue 186. @@ -153,58 +153,58 @@ modelBase_nClass <- nClass( compileInfo = list( C_fun = function(instrList = 'nList(instr_nClass)') { ## NOTE: instrList input will be ordered. - cppLiteral('modelClass_::calculate(instrList);') - }, - virtual=TRUE - ) - ), - calculateDiff_impl = nFunction( - name = "calculateDiff_impl", - function(instrList) { - cat("Uncompiled `calculateDiff_impl` should never be called.\n") - return(0) - }, - returnType = 'numericScalar', - compileInfo = list( - C_fun = function(instrList = 'nList(instr_nClass)') { - ## NOTE: instrList input will be ordered. - cppLiteral('modelClass_::calculateDiff(instrList);') - }, - virtual=TRUE - ) - ), - simulate_impl = nFunction( - name = "simulate_impl", - function(instrList) { - cat("Uncompiled `simulate_impl` should never be called.\n") - }, - compileInfo = list( - C_fun = function(instrList = 'nList(instr_nClass)') { - cppLiteral('modelClass_::simulate(instrList);') - }, - virtual=TRUE - ) - ), - getLogProb_impl = nFunction( - name = "getLogProb_impl", - function(instrList) { - cat("Uncompiled `getLogProb_impl` should never be called.\n") - }, - returnType = 'numericScalar', - compileInfo = list( - C_fun = function(instrList = 'nList(instr_nClass)') { - cppLiteral('modelClass_::getLogProb(instrList);') + cppLiteral('Rprintf("modelBase_nClass calculate_impl (should not see this)\\n");'); return(0) }, virtual=TRUE ) - ) + )#, + # calculateDiff_impl = nFunction( + # name = "calculateDiff_impl", + # function(instrList) { + # cat("Uncompiled `calculateDiff_impl` should never be called.\n") + # return(0) + # }, + # returnType = 'numericScalar', + # compileInfo = list( + # C_fun = function(instrList = 'nList(instr_nClass)') { + # ## NOTE: instrList input will be ordered. + # cppLiteral('modelClass_::calculateDiff(instrList);') + # }, + # virtual=TRUE + # ) + # ), + # simulate_impl = nFunction( + # name = "simulate_impl", + # function(instrList) { + # cat("Uncompiled `simulate_impl` should never be called.\n") + # }, + # compileInfo = list( + # C_fun = function(instrList = 'nList(instr_nClass)') { + # cppLiteral('modelClass_::simulate(instrList);') + # }, + # virtual=TRUE + # ) + # ), + # getLogProb_impl = nFunction( + # name = "getLogProb_impl", + # function(instrList) { + # cat("Uncompiled `getLogProb_impl` should never be called.\n") + # }, + # returnType = 'numericScalar', + # compileInfo = list( + # C_fun = function(instrList = 'nList(instr_nClass)') { + # cppLiteral('modelClass_::getLogProb(instrList);') + # }, + # virtual=TRUE + # ) + # ) ), ## See comment above about needing to ensure a virtual destructor predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("modelBase_nC")), compileInfo=list(interface="full", createFromR = FALSE, Hincludes = c('"declFunBase_nClass_c_.h","instr_nClass_c_.h"'), - needed_units = list("declFunBase_nClass","instr_nClass"), + needed_units = list("declFunBase_nClass","instr_nClass", "nList(instr_nClass)"), exportName = "modelBase_nClass_new", packageNames = c(uncompiled="modelBase_nClass_R", compiled="modelBase_nClass") ) diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_copyFiles.txt b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_copyFiles.txt new file mode 100644 index 0000000..e69de29 diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_cppContent.cpp b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_cppContent.cpp new file mode 100644 index 0000000..072b8ff --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_cppContent.cpp @@ -0,0 +1,57 @@ +/* OPENER (Do not edit this comment) */ +#ifndef __declFunBase_nClass_CPP +#define __declFunBase_nClass_CPP +/* BODY (Do not edit this comment) */ +#ifndef R_NO_REMAP +#define R_NO_REMAP +#endif +#include +#include "declFunBase_nClass_c_.h" +using namespace Rcpp; +// [[Rcpp::plugins(nCompiler_Eigen_plugin)]] +// [[Rcpp::depends(RcppParallel)]] +// [[Rcpp::depends(nCompiler)]] +// [[Rcpp::depends(Rcereal)]] + + bool declFunBase_nClass::ping ( ) { +RESET_EIGEN_ERRORS +return(true); +} + double declFunBase_nClass::calculate ( std::shared_ptr instr ) { +RESET_EIGEN_ERRORS +if((instr)->type==0.0) { + return(calc_0(instr)); +} +return(0.0); +} + double declFunBase_nClass::calc_0 ( std::shared_ptr instr ) { +RESET_EIGEN_ERRORS +Rprintf("declFunBase_nClass calc_0 (should not see this)\n");; +return(0.0); +} + declFunBase_nClass::declFunBase_nClass ( ) { +RESET_EIGEN_ERRORS +} + +// [[Rcpp::export(name = "set_CnClass_env_declFunBase_nClass_new")]] + void set_CnClass_env_declFunBase_nClass ( SEXP env ) { +RESET_EIGEN_ERRORS +SET_CNCLASS_ENV(declFunBase_nClass, env);; +} + +// [[Rcpp::export(name = "get_CnClass_env_declFunBase_nClass_new")]] + Rcpp::Environment get_CnClass_env_declFunBase_nClass ( ) { +RESET_EIGEN_ERRORS +return GET_CNCLASS_ENV(declFunBase_nClass);; +} + +NCOMPILER_INTERFACE( +declFunBase_nClass, +NCOMPILER_FIELDS(), +NCOMPILER_METHODS( +method("ping", &declFunBase_nClass::ping, args({{}})), +method("calculate", &declFunBase_nClass::calculate, args({{arg("instr",copy)}})), +method("calc_0", &declFunBase_nClass::calc_0, args({{arg("instr",copy)}})) +) +) +#endif diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_filebase.txt b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_filebase.txt new file mode 100644 index 0000000..75d0892 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_filebase.txt @@ -0,0 +1 @@ +declFunBase_nClass_c_ diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_hContent.h b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_hContent.h new file mode 100644 index 0000000..8be55e8 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_hContent.h @@ -0,0 +1,24 @@ +/* OPENER (Do not edit this comment) */ +#ifndef __declFunBase_nClass_H +#define __declFunBase_nClass_H +/* BODY (Do not edit this comment) */ +#ifndef R_NO_REMAP +#define R_NO_REMAP +#endif +#include +#include "instr_nClass_c_.h" + +class declFunBase_nClass : public interface_resolver< genericInterfaceC >, public loadedObjectHookC { +public: + virtual bool ping ( ) ; + virtual double calculate ( std::shared_ptr instr ) ; + virtual double calc_0 ( std::shared_ptr instr ) ; + declFunBase_nClass ( ) ; +}; + + void set_CnClass_env_declFunBase_nClass ( SEXP env ) ; + + Rcpp::Environment get_CnClass_env_declFunBase_nClass ( ) ; + + +#endif diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_manifest.txt b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_manifest.txt new file mode 100644 index 0000000..9d2ef84 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_manifest.txt @@ -0,0 +1,7 @@ +list(saved_at = structure(1780087606.61385, class = c("POSIXct", +"POSIXt")), packet_name = "declFunBase_nClass", elements = c("preamble", +"cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" +), files = list(preamble = "declFunBase_nClass_preamble.cpp", + cppContent = "declFunBase_nClass_cppContent.cpp", hContent = "declFunBase_nClass_hContent.h", + filebase = "declFunBase_nClass_filebase.txt", post_cpp_compiler = "declFunBase_nClass_post_cpp_compiler.txt", + copyFiles = "declFunBase_nClass_copyFiles.txt")) diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt new file mode 100644 index 0000000..e69de29 diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_preamble.cpp b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_preamble.cpp new file mode 100644 index 0000000..1a92ce3 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_preamble.cpp @@ -0,0 +1,5 @@ +#define NCOMPILER_HANDLE_EIGEN_ERRORS +#define NCOMPILER_USES_EIGEN +#define NCOMPILER_USES_NCPPVEC +#define USES_NCOMPILER +#define NCOMPILER_USES_NCLASS_INTERFACE diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_copyFiles.txt b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_copyFiles.txt new file mode 100644 index 0000000..e69de29 diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp new file mode 100644 index 0000000..b161d1c --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp @@ -0,0 +1,53 @@ +/* OPENER (Do not edit this comment) */ +#ifndef __instr_nClass_CPP +#define __instr_nClass_CPP +/* BODY (Do not edit this comment) */ +#ifndef R_NO_REMAP +#define R_NO_REMAP +#endif +#include +#include "instr_nClass_c_.h" +using namespace Rcpp; +// [[Rcpp::plugins(nCompiler_Eigen_plugin)]] +// [[Rcpp::depends(RcppParallel)]] +// [[Rcpp::depends(nCompiler)]] +// [[Rcpp::depends(Rcereal)]] + + instr_nClass::instr_nClass ( ) { +RESET_EIGEN_ERRORS +} + +// [[Rcpp::export(name = "instr_nClass_new")]] + SEXP new_instr_nClass ( ) { +RESET_EIGEN_ERRORS +return CREATE_NEW_NCOMP_OBJECT(instr_nClass);; +} + +// [[Rcpp::export(name = "set_CnClass_env_instr_nClass_new")]] + void set_CnClass_env_instr_nClass ( SEXP env ) { +RESET_EIGEN_ERRORS +SET_CNCLASS_ENV(instr_nClass, env);; +} + +// [[Rcpp::export(name = "get_CnClass_env_instr_nClass_new")]] + Rcpp::Environment get_CnClass_env_instr_nClass ( ) { +RESET_EIGEN_ERRORS +return GET_CNCLASS_ENV(instr_nClass);; +} + +NCOMPILER_INTERFACE( +instr_nClass, +NCOMPILER_FIELDS( +field("lens", &instr_nClass::lens), +field("index_types", &instr_nClass::index_types), +field("dim", &instr_nClass::dim), +field("dims", &instr_nClass::dims), +field("slots", &instr_nClass::slots), +field("values", &instr_nClass::values), +field("type", &instr_nClass::type), +field("sortID", &instr_nClass::sortID), +field("declID", &instr_nClass::declID) +), +NCOMPILER_METHODS() +) +#endif diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_filebase.txt b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_filebase.txt new file mode 100644 index 0000000..ba6031f --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_filebase.txt @@ -0,0 +1 @@ +instr_nClass_c_ diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h new file mode 100644 index 0000000..615ee99 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h @@ -0,0 +1,32 @@ +/* OPENER (Do not edit this comment) */ +#ifndef __instr_nClass_H +#define __instr_nClass_H +/* BODY (Do not edit this comment) */ +#ifndef R_NO_REMAP +#define R_NO_REMAP +#endif +#include +#include "nList_I1_c_.h" + +class instr_nClass : public interface_resolver< genericInterfaceC >, public loadedObjectHookC { +public: + instr_nClass ( ) ; + Eigen::Tensor lens; + Eigen::Tensor index_types; + int dim; + Eigen::Tensor dims; + Eigen::Tensor slots; + std::shared_ptr values; + int type; + Eigen::Tensor sortID; + int declID; +}; + + SEXP new_instr_nClass ( ) ; + + void set_CnClass_env_instr_nClass ( SEXP env ) ; + + Rcpp::Environment get_CnClass_env_instr_nClass ( ) ; + + +#endif diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_manifest.txt b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_manifest.txt new file mode 100644 index 0000000..ec3592a --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_manifest.txt @@ -0,0 +1,7 @@ +list(saved_at = structure(1780087567.77333, class = c("POSIXct", +"POSIXt")), packet_name = "instr_nClass", elements = c("preamble", +"cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" +), files = list(preamble = "instr_nClass_preamble.cpp", cppContent = "instr_nClass_cppContent.cpp", + hContent = "instr_nClass_hContent.h", filebase = "instr_nClass_filebase.txt", + post_cpp_compiler = "instr_nClass_post_cpp_compiler.txt", + copyFiles = "instr_nClass_copyFiles.txt")) diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_post_cpp_compiler.txt b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_post_cpp_compiler.txt new file mode 100644 index 0000000..e69de29 diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_preamble.cpp b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_preamble.cpp new file mode 100644 index 0000000..1a92ce3 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_preamble.cpp @@ -0,0 +1,5 @@ +#define NCOMPILER_HANDLE_EIGEN_ERRORS +#define NCOMPILER_USES_EIGEN +#define NCOMPILER_USES_NCPPVEC +#define USES_NCOMPILER +#define NCOMPILER_USES_NCLASS_INTERFACE diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_copyFiles.txt b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_copyFiles.txt new file mode 100644 index 0000000..e69de29 diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_cppContent.cpp b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_cppContent.cpp new file mode 100644 index 0000000..c0b1a82 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_cppContent.cpp @@ -0,0 +1,52 @@ +/* OPENER (Do not edit this comment) */ +#ifndef __modelBase_nClass_CPP +#define __modelBase_nClass_CPP +/* BODY (Do not edit this comment) */ +#ifndef R_NO_REMAP +#define R_NO_REMAP +#endif +#include +#include "modelBase_nClass_c_.h" +using namespace Rcpp; +// [[Rcpp::plugins(nCompiler_Eigen_plugin)]] +// [[Rcpp::depends(RcppParallel)]] +// [[Rcpp::depends(nCompiler)]] +// [[Rcpp::depends(Rcereal)]] + + bool modelBase_nClass::ping ( ) { +RESET_EIGEN_ERRORS +return(true); +} + double modelBase_nClass::calculate_impl ( std::shared_ptr instrList ) { +RESET_EIGEN_ERRORS +Rprintf("modelBase_nClass calculate_impl (should not see this)\n");; +return(0.0); +} + modelBase_nClass::modelBase_nClass ( ) { +RESET_EIGEN_ERRORS +} + +// [[Rcpp::export(name = "set_CnClass_env_modelBase_nClass_new")]] + void set_CnClass_env_modelBase_nClass ( SEXP env ) { +RESET_EIGEN_ERRORS +SET_CNCLASS_ENV(modelBase_nClass, env);; +} + +// [[Rcpp::export(name = "get_CnClass_env_modelBase_nClass_new")]] + Rcpp::Environment get_CnClass_env_modelBase_nClass ( ) { +RESET_EIGEN_ERRORS +return GET_CNCLASS_ENV(modelBase_nClass);; +} + +NCOMPILER_INTERFACE( +modelBase_nClass, +NCOMPILER_FIELDS( +field("declFunList", &modelBase_nClass::declFunList), +field("declFunNameToIndex", &modelBase_nClass::declFunNameToIndex) +), +NCOMPILER_METHODS( +method("ping", &modelBase_nClass::ping, args({{}})), +method("calculate_impl", &modelBase_nClass::calculate_impl, args({{arg("instrList",copy)}})) +) +) +#endif diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_filebase.txt b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_filebase.txt new file mode 100644 index 0000000..e8994f8 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_filebase.txt @@ -0,0 +1 @@ +modelBase_nClass_c_ diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_hContent.h b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_hContent.h new file mode 100644 index 0000000..a233c66 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_hContent.h @@ -0,0 +1,26 @@ +/* OPENER (Do not edit this comment) */ +#ifndef __modelBase_nClass_H +#define __modelBase_nClass_H +/* BODY (Do not edit this comment) */ +#ifndef R_NO_REMAP +#define R_NO_REMAP +#endif +#include +#include "declFunBase_nClass_c_.h","instr_nClass_c_.h" +#include "nList_instr_nClass_c_.h" + +class modelBase_nClass : public interface_resolver< genericInterfaceC >, public loadedObjectHookC { +public: + virtual bool ping ( ) ; + virtual double calculate_impl ( std::shared_ptr instrList ) ; + modelBase_nClass ( ) ; + double declFunList; + Rcpp::List declFunNameToIndex; +}; + + void set_CnClass_env_modelBase_nClass ( SEXP env ) ; + + Rcpp::Environment get_CnClass_env_modelBase_nClass ( ) ; + + +#endif diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_manifest.txt b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_manifest.txt new file mode 100644 index 0000000..d119dd3 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_manifest.txt @@ -0,0 +1,7 @@ +list(saved_at = structure(1780087638.0725, class = c("POSIXct", +"POSIXt")), packet_name = "modelBase_nClass", elements = c("preamble", +"cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" +), files = list(preamble = "modelBase_nClass_preamble.cpp", cppContent = "modelBase_nClass_cppContent.cpp", + hContent = "modelBase_nClass_hContent.h", filebase = "modelBase_nClass_filebase.txt", + post_cpp_compiler = "modelBase_nClass_post_cpp_compiler.txt", + copyFiles = "modelBase_nClass_copyFiles.txt")) diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt new file mode 100644 index 0000000..e69de29 diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_preamble.cpp b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_preamble.cpp new file mode 100644 index 0000000..1a92ce3 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_preamble.cpp @@ -0,0 +1,5 @@ +#define NCOMPILER_HANDLE_EIGEN_ERRORS +#define NCOMPILER_USES_EIGEN +#define NCOMPILER_USES_NCPPVEC +#define USES_NCOMPILER +#define NCOMPILER_USES_NCLASS_INTERFACE diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 4889788..eb6bd25 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -9,20 +9,20 @@ library(testthat) ## # To update the set of predefined nClasses ## # generate new predef/instr_nC. Move that directly to package code inst/nimbleModel/predef/instr_nC -## nCompile(instr_nClass, control=list(generate_predefined=TRUE)) -## test <- nCompile(instr_nClass) +nCompile(instr_nClass = nimbleModel:::instr_nClass, control=list(generate_predefined=TRUE)) +test <- nCompile(instr_nClass = nimbleModel:::instr_nClass) ## # ## # generate new predef/declFunBase_nC. Move to package and add ## # "#include " in the hContent ## # after declaration of declFunBase_nClass -## nCompile(declFunBase_nClass, control=list(generate_predefined=TRUE)) -## test <- nCompile(declFunBase_nClass) +nCompile(nimbleModel:::declFunBase_nClass, control=list(generate_predefined=TRUE)) +test <- nCompile(nimbleModel:::declFunBase_nClass) ## # ## # generate new predef/modelBase_nC. Move to package and add ## # "#include " to that file, ## # after the declaration of modelBase_nClass. -## nCompile(modelBase_nClass, control=list(generate_predefined=TRUE)) -## test <- nCompile(modelBase_nClass) + nCompile(modelBase_nClass = nimbleModel:::modelBase_nClass, control=list(generate_predefined=TRUE)) + test <- nCompile(nimbleModel:::modelBase_nClass) ## #nCompile(instr_nClass, modelBase_nClass, declFunBase_nClass, control=list(generate_predefined=TRUE)) ## TODO: revise these tests for instrClass (flattened approach) @@ -43,6 +43,13 @@ test_that("initial tests/examples of nimble model using flattened approach", { ## "Manual" workflow not using `nimbleModel()`. nm <- modelClass$new(code, inits = inits, data = data) mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) + + # Begin Perry + + + # End Perry + + m <- mclass$new() lp_tau <- dunif(m$tau, 0, 100, log = TRUE) @@ -100,7 +107,7 @@ test_that("initial tests/examples of nimble model using flattened approach", { mclass <- nimbleModel(code, data = data, inits = inits) m <- mclass$new(inits = list(tau = 7)) expect_identical(m$tau, 7) - + }) test_that("basic creation of list of instr_nClass objects", { @@ -127,7 +134,7 @@ test_that("basic creation of list of instr_nClass objects", { expect_identical(instr1$values[[1]], 2) # offset expect_identical(instr1$index_types, 1) expect_identical(instr1$type, 1) - + instr2 <- makeInstrList(m, c('y[c(2,5)]'))[[1]] expect_identical(instr2$lens, 2) expect_identical(instr2$values[[1]], c(2,5)) From 8053561b756d1c4e3e3572690a3abe98bf11ee4c Mon Sep 17 00:00:00 2001 From: perrydv Date: Sun, 31 May 2026 14:12:00 -0700 Subject: [PATCH 23/32] model compiled and call path to calculate_impl works --- nimbleModel/R/instructions.R | 41 +++-- nimbleModel/R/modelBaseClass.R | 19 ++- nimbleModel/R/nimbleModel.R | 12 +- .../nimbleModel/modelBase_nC/.DS_Store | Bin 0 -> 6148 bytes .../declFunBase_nClass_copyFiles.txt | 0 .../declFunBase_nClass_cppContent.cpp | 1 + .../declFunBase_nClass_filebase.txt | 0 .../declFunBase_nClass_hContent.h | 1 + .../declFunBase_nClass_manifest.txt | 0 .../declFunBase_nClass_post_cpp_compiler.txt | 0 .../declFunBase_nClass_preamble.cpp | 0 .../declFunClass_/declFunClass_.h | 21 +++ .../instr_nClass/instr_nClass_copyFiles.txt | 0 .../instr_nClass/instr_nClass_cppContent.cpp | 1 + .../instr_nClass/instr_nClass_filebase.txt | 0 .../instr_nClass/instr_nClass_hContent.h | 0 .../instr_nClass/instr_nClass_manifest.txt | 2 +- .../instr_nClass_post_cpp_compiler.txt | 0 .../instr_nClass/instr_nClass_preamble.cpp | 0 .../modelBase_nClass_copyFiles.txt | 0 .../modelBase_nClass_cppContent.cpp | 9 ++ .../modelBase_nClass_filebase.txt | 0 .../modelBase_nC/modelBase_nClass_hContent.h | 5 +- .../modelBase_nClass_manifest.txt | 2 +- .../modelBase_nClass_post_cpp_compiler.txt | 0 .../modelBase_nClass_preamble.cpp | 0 .../modelBase_nC/modelClass_/modelClass_.h | 153 ++++++++++++++++++ nimbleModel/tests/testthat/test-nimbleModel.R | 63 +++++++- 28 files changed, 296 insertions(+), 34 deletions(-) create mode 100644 nimbleModel/inst/include/nimbleModel/modelBase_nC/.DS_Store rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/declFunBase_nC/declFunBase_nClass_copyFiles.txt (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/declFunBase_nC/declFunBase_nClass_cppContent.cpp (97%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/declFunBase_nC/declFunBase_nClass_filebase.txt (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/declFunBase_nC/declFunBase_nClass_hContent.h (92%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/declFunBase_nC/declFunBase_nClass_manifest.txt (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/declFunBase_nC/declFunBase_nClass_preamble.cpp (100%) create mode 100644 nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunClass_/declFunClass_.h rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/instr_nClass/instr_nClass_copyFiles.txt (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/instr_nClass/instr_nClass_cppContent.cpp (97%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/instr_nClass/instr_nClass_filebase.txt (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/instr_nClass/instr_nClass_hContent.h (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/instr_nClass/instr_nClass_manifest.txt (87%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/instr_nClass/instr_nClass_post_cpp_compiler.txt (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/instr_nClass/instr_nClass_preamble.cpp (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/modelBase_nC/modelBase_nClass_copyFiles.txt (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/modelBase_nC/modelBase_nClass_cppContent.cpp (79%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/modelBase_nC/modelBase_nClass_filebase.txt (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/modelBase_nC/modelBase_nClass_hContent.h (78%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/modelBase_nC/modelBase_nClass_manifest.txt (87%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt (100%) rename nimbleModel/inst/include/nimbleModel/{predef => modelBase_nC}/modelBase_nC/modelBase_nClass_preamble.cpp (100%) create mode 100644 nimbleModel/inst/include/nimbleModel/modelBase_nC/modelClass_/modelClass_.h diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index 0c7faa7..4b49eab 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -129,21 +129,24 @@ makeInstrList <- function(model, input, use_vec = FALSE) { instr_nClass <- nClass( classname = "instr_nClass", Rpublic = list( - initialize = function(calcRange) { - instr <- range2instr(calcRange) # This processing could simply be included here in `initialize`. - self$lens <- instr$lens - self$index_types <- instr$index_types - self$dim <- instr$dim - self$dims <- instr$dims - self$slots <- instr$slots - self$values <- nList(integerVector)$new() - self$values$setLength(length(self$dims)) - if(self$dim) - for(i in 1:length(self$dims)) - self$values[[i]] <- instr$values[[i]] - self$type <- instr$type # Use integer for compilation (would char be ok?). - self$sortID <- instr$sortID - self$declID <- instr$declID + initialize = function(calcRange, ...) { + super$initialize(...) + if(!missing(calcRange)) { + instr <- range2instr(calcRange) # This processing could simply be included here in `initialize`. + self$lens <- instr$lens %||% integer() + self$index_types <- instr$index_types %||% integer() + self$dim <- instr$dim %||% 0L + self$dims <- instr$dims %||% integer() + self$slots <- instr$slots %||% integer() + self$values <- nList(integerVector)$new() + self$values$setLength(length(self$dims)) + if(self$dim) + for(i in 1:length(self$dims)) + self$values[[i]] <- instr$values[[i]] + self$type <- instr$type %||% 0L # Use integer for compilation (would char be ok?). + self$sortID <- instr$sortID %||% integer() + self$declID <- instr$declID %||% 0L + } }), Cpublic = list( lens = 'integerVector', @@ -154,7 +157,13 @@ instr_nClass <- nClass( values = 'nList(integerVector)', type = 'integerScalar', sortID = 'integerVector', - declID = 'integerScalar' + declID = 'integerScalar', + instr_nClass = nFunction( + function() { + values <- nList(integerVector)$new() + }, + compileInfo = list(constructor=TRUE) + ) ), predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("instr_nClass")), compileInfo = list(interface = "full", diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index a40986e..87efdca 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -7,11 +7,11 @@ modelBase_nClass <- nClass( nondataRules = NULL, predictiveRules = NULL, nonpredictiveRules = NULL, - initialize = function(sizes = list(), inits = list(), data = list()) { + initialize = function(sizes = list(), inits = list(), data = list(), ...) { # It is not very easy to set debug onto the initialize function, so # here is a magic flag. if(isTRUE(.GlobalEnv$.debugModelInit)) browser() - super$initialize() + super$initialize(...) ## TODO: is there a better way to populate declFunNameToIndex in Cpublic? declFunNameToIndex <- self$declFunNameToIndex_ @@ -90,8 +90,10 @@ modelBase_nClass <- nClass( if(missing(input)) input <- getVarNames() instrList <- makeInstrList(self,input) - if(isCompiled()) + if(isCompiled()) { + if(!instrList$isCompiled()) instrList <- makeCompiledInstrList(instrList) return(calculate_impl(instrList)) + } logProb <- 0 for(i in 1:length(instrList)) { logProb <- logProb + declFunList[[instrList[[i]]$declID]]$calculate(instrList[[i]]) @@ -143,6 +145,15 @@ modelBase_nClass <- nClass( function() {return(TRUE); returnType(logical())}, compileInfo = list(virtual=TRUE) ), + makeCompiledInstrList = nFunction( + name = "makeCompiledInstrList", + function(input = 'SEXP') { + ans <- nList(instr_nClass)$new() + cppLiteral("ans->set_all_values(input);") + return(ans) + }, + returnType = 'nList(instr_nClass)' + ), calculate_impl = nFunction( name = "calculate_impl", function(instrList) { @@ -203,7 +214,7 @@ modelBase_nClass <- nClass( predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("modelBase_nC")), compileInfo=list(interface="full", createFromR = FALSE, - Hincludes = c('"declFunBase_nClass_c_.h","instr_nClass_c_.h"'), + Hincludes = c('"declFunBase_nClass_c_.h"','"instr_nClass_c_.h"'), needed_units = list("declFunBase_nClass","instr_nClass", "nList(instr_nClass)"), exportName = "modelBase_nClass_new", packageNames = c(uncompiled="modelBase_nClass_R", compiled="modelBase_nClass") diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index ebe27d5..f8e2336 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -222,12 +222,12 @@ makeModel_nClass <- function(modelVarInfo, compileInfo=list( C_fun = function(declNames="RcppCharacterVector") {do_setup_decl_mgmt_from_names(declNames)}) ), - print_decls = nFunction( - name = "print_decls", - function() {}, - compileInfo=list( - C_fun = function() {cppLiteral('modelClass_::c_print_decls();')}) - ), + # print_decls = nFunction( + # name = "print_decls", + # function() {}, + # compileInfo=list( + # C_fun = function() {cppLiteral('modelClass_::c_print_decls();')}) + # ), set_from_list = nFunction( name = "set_from_list", function(Rlist) {for(v in names(Rlist)) diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/.DS_Store b/nimbleModel/inst/include/nimbleModel/modelBase_nC/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..a39061b8ebb30b64ba5c9d872536be6251fcf2a6 GIT binary patch literal 6148 zcmeHKu};H44E2=`sam0qu-z~84?+kmNC?r90ccaT5(%k~T&jdZdKz>8asu zhQG)F-`yc)G@~iyRKLF&-Qq4!^Z95zEsLcjKe*oIUzBM&$;%1+qL=5(o8!0Flie}d zuVa>rdR|wY-hc`!!&!3u4Yr=4|NfnCJ^zo3-h<}9b?>75%Kaz)EqQb9CdPmSKprT7RM1a{98V60dP!UC~B0)Yk_ JjDfu}@ChpJUdI3c literal 0 HcmV?d00001 diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_copyFiles.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_copyFiles.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_copyFiles.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_copyFiles.txt diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_cppContent.cpp b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_cppContent.cpp similarity index 97% rename from nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_cppContent.cpp rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_cppContent.cpp index 072b8ff..115eab4 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_cppContent.cpp +++ b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_cppContent.cpp @@ -11,6 +11,7 @@ using namespace Rcpp; // [[Rcpp::plugins(nCompiler_Eigen_plugin)]] // [[Rcpp::depends(RcppParallel)]] // [[Rcpp::depends(nCompiler)]] +// [[Rcpp::depends(nimbleModel)]] // [[Rcpp::depends(Rcereal)]] bool declFunBase_nClass::ping ( ) { diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_filebase.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_filebase.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_filebase.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_filebase.txt diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_hContent.h b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_hContent.h similarity index 92% rename from nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_hContent.h rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_hContent.h index 8be55e8..2cdb615 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_hContent.h +++ b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_hContent.h @@ -20,5 +20,6 @@ class declFunBase_nClass : public interface_resolver< genericInterfaceC #endif diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_manifest.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_manifest.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_manifest.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_manifest.txt diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_preamble.cpp b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_preamble.cpp similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_preamble.cpp rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_preamble.cpp diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunClass_/declFunClass_.h b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunClass_/declFunClass_.h new file mode 100644 index 0000000..0c26dfe --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunClass_/declFunClass_.h @@ -0,0 +1,21 @@ +// to be included from the predefined nodeFxnBase_nClass. +// Add "#include " to that file, +// after the declaration of nodeFxnBase_nClass. + +template +class declFunClass_ : public declFunBase_nClass { +public: + double v; + declFunClass_() {}; + + double calculate ( std::shared_ptr nodeInstr ) override { +RESET_EIGEN_ERRORS +double logProb(0.0); +// const auto& methodInstr = nodeInstr->methodInstr; +// const auto& indsInstrVec = nodeInstr->indsInstrVec; +// logProb += static_cast(this)->calc_one((*indsInstrVec)[0]); +return(logProb); + } + + virtual ~declFunClass_() {}; +}; diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_copyFiles.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_copyFiles.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_copyFiles.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_copyFiles.txt diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp b/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_cppContent.cpp similarity index 97% rename from nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_cppContent.cpp index b161d1c..66a0779 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp +++ b/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_cppContent.cpp @@ -15,6 +15,7 @@ using namespace Rcpp; instr_nClass::instr_nClass ( ) { RESET_EIGEN_ERRORS +values = nClass_builder()(); } // [[Rcpp::export(name = "instr_nClass_new")]] diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_filebase.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_filebase.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_filebase.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_filebase.txt diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h b/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_hContent.h similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_hContent.h diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_manifest.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_manifest.txt similarity index 87% rename from nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_manifest.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_manifest.txt index ec3592a..ad88dd7 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_manifest.txt +++ b/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_manifest.txt @@ -1,4 +1,4 @@ -list(saved_at = structure(1780087567.77333, class = c("POSIXct", +list(saved_at = structure(1780186830.15166, class = c("POSIXct", "POSIXt")), packet_name = "instr_nClass", elements = c("preamble", "cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" ), files = list(preamble = "instr_nClass_preamble.cpp", cppContent = "instr_nClass_cppContent.cpp", diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_post_cpp_compiler.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_post_cpp_compiler.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_post_cpp_compiler.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_post_cpp_compiler.txt diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_preamble.cpp b/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_preamble.cpp similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_preamble.cpp rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_preamble.cpp diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_copyFiles.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_copyFiles.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_copyFiles.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_copyFiles.txt diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_cppContent.cpp b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_cppContent.cpp similarity index 79% rename from nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_cppContent.cpp rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_cppContent.cpp index c0b1a82..c54588c 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_cppContent.cpp +++ b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_cppContent.cpp @@ -12,10 +12,18 @@ using namespace Rcpp; // [[Rcpp::depends(RcppParallel)]] // [[Rcpp::depends(nCompiler)]] // [[Rcpp::depends(Rcereal)]] +// [[Rcpp::depends(nimbleModel)]] bool modelBase_nClass::ping ( ) { RESET_EIGEN_ERRORS return(true); +} + std::shared_ptr modelBase_nClass::makeCompiledInstrList ( SEXP input ) { +RESET_EIGEN_ERRORS +std::shared_ptr ans; +ans = nClass_builder()(); +ans->set_all_values(input);; +return(ans); } double modelBase_nClass::calculate_impl ( std::shared_ptr instrList ) { RESET_EIGEN_ERRORS @@ -46,6 +54,7 @@ field("declFunNameToIndex", &modelBase_nClass::declFunNameToIndex) ), NCOMPILER_METHODS( method("ping", &modelBase_nClass::ping, args({{}})), +method("makeCompiledInstrList", &modelBase_nClass::makeCompiledInstrList, args({{arg("input",copy)}})), method("calculate_impl", &modelBase_nClass::calculate_impl, args({{arg("instrList",copy)}})) ) ) diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_filebase.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_filebase.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_filebase.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_filebase.txt diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_hContent.h b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_hContent.h similarity index 78% rename from nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_hContent.h rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_hContent.h index a233c66..3a47468 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_hContent.h +++ b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_hContent.h @@ -6,12 +6,14 @@ #define R_NO_REMAP #endif #include -#include "declFunBase_nClass_c_.h","instr_nClass_c_.h" +#include "declFunBase_nClass_c_.h" +#include "instr_nClass_c_.h" #include "nList_instr_nClass_c_.h" class modelBase_nClass : public interface_resolver< genericInterfaceC >, public loadedObjectHookC { public: virtual bool ping ( ) ; + std::shared_ptr makeCompiledInstrList ( SEXP input ) ; virtual double calculate_impl ( std::shared_ptr instrList ) ; modelBase_nClass ( ) ; double declFunList; @@ -22,5 +24,6 @@ class modelBase_nClass : public interface_resolver< genericInterfaceC #endif diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_manifest.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_manifest.txt similarity index 87% rename from nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_manifest.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_manifest.txt index d119dd3..36cdfdd 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_manifest.txt +++ b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_manifest.txt @@ -1,4 +1,4 @@ -list(saved_at = structure(1780087638.0725, class = c("POSIXct", +list(saved_at = structure(1780261611.74136, class = c("POSIXct", "POSIXt")), packet_name = "modelBase_nClass", elements = c("preamble", "cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" ), files = list(preamble = "modelBase_nClass_preamble.cpp", cppContent = "modelBase_nClass_cppContent.cpp", diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt diff --git a/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_preamble.cpp b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_preamble.cpp similarity index 100% rename from nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_preamble.cpp rename to nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_preamble.cpp diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelClass_/modelClass_.h b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelClass_/modelClass_.h new file mode 100644 index 0000000..69f5b8a --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelClass_/modelClass_.h @@ -0,0 +1,153 @@ +// to be included from the predefined modelBase_nClass. +// Add "#include " to that file, +// after the declaration of modelBase_nClass. + + +template +class modelClass_ : public modelBase_nClass { +public: + modelClass_() {}; + std::vector< std::shared_ptr > nodeFxnPtrs; + std::map name2index_map; + double calculate_impl(std::shared_ptr calcInstrList) override { + double logProb(0.0); + // const auto& calcInstrVec = calcInstrList->contents(); + // auto calcInstr = calcInstrVec.cbegin(); + // auto calcInstrEnd = calcInstrVec.cend(); + // for( ; calcInstr != calcInstrEnd; ++calcInstr) { + // auto nodeFxnPtr = nodeFxnPtrs[(*calcInstr)->nodeIndex-1]; + // const auto& nodeInstrVec = (*calcInstr)->nodeInstrVec->contents(); + // auto nodeInstr = nodeInstrVec.cbegin(); + // auto nodeInstrEnd = nodeInstrVec.cend(); + // for( ; nodeInstr != nodeInstrEnd; ) { + // logProb += nodeFxnPtr->calculate(*nodeInstr++); + // } + // } + return(logProb); + } + + // This version takes a character vector of names from R so that + // the ordering of nodeFxns matches that in R, which is important for + // the calculation instructions. + void do_setup_decl_mgmt_from_names(Rcpp::CharacterVector names) { + Rprintf("Attempting setup_decl_mgmt_from_names with %d names\n", (int)names.length()); + Derived *self = static_cast(this); + const auto& name2access = self->get_name2access(); + nodeFxnPtrs.clear(); + name2index_map.clear(); + size_t n = names.length(); + for(size_t i = 0; i < n; ++i) { + std::string name = Rcpp::as(names[i]); + auto it = name2access.find(name); + if(it != name2access.end()) { + std::shared_ptr ptr = it->second->getInterfacePtr(dynamic_cast(self)); + // When looking up this way, we do expect always to find objects (ptr valid) and that they are nodeFxn ptrs (ptr2 valid). + // So we can turn these messages into errors once things are working. + bool got_one = (ptr != nullptr); + if(got_one) { + Rprintf("HOORAY: field %s is genericInterfaceBaseC\n", name.c_str()); + std::shared_ptr ptr2 = std::dynamic_pointer_cast(ptr); + bool step_two = (ptr2 != nullptr); + if(step_two) { + Rprintf("AND IT IS A NODEFXN PTR!\n"); + name2index_map.emplace(name, nodeFxnPtrs.size()); + nodeFxnPtrs.push_back(ptr2); + } else { + Rprintf("but it is not a nodefxn ptr\n"); + } + } else { + Rprintf("field %s is NOT a genericInterfaceBaseC\n", name.c_str()); + } + } + } + } + + // This version scans all members to find nodeFxns. + // The resulting ordering comes from the order of the name2access map, + // and so may not match R. This was written first but may fall out of common use. + void setup_decl_mgmt() { + Derived *self = static_cast(this); + const auto& name2access = self->get_name2access(); + size_t n = name2access.size(); + Rprintf("There are %d member variables indexed:\n", (int)n); + auto i_n2a = name2access.begin(); + auto end_n2a = name2access.end(); + nodeFxnPtrs.clear(); + name2index_map.clear(); + size_t index = 0; + for(; i_n2a != end_n2a; ++i_n2a) { + std::shared_ptr ptr = i_n2a->second->getInterfacePtr(dynamic_cast(self)); + bool got_one = (ptr != nullptr); + if(got_one) { + Rprintf("HOORAY: field %s is genericInterfaceBaseC\n", i_n2a->first.c_str()); + std::shared_ptr ptr2 = std::dynamic_pointer_cast(ptr); + bool step_two = (ptr2 != nullptr); + if(step_two) { + Rprintf("AND IT IS A NODEFXN PTR!\n"); + nodeFxnPtrs.push_back(ptr2); + name2index_map.emplace(i_n2a->first, index++); + } else { + Rprintf("but it is not a nodefxn ptr\n"); + } + } + else + Rprintf("field %s is NOT a genericInterfaceBaseC\n", i_n2a->first.c_str()); + } + } + void c_print_nodes() { + auto i_n2i = name2index_map.begin(); + auto end_n2i = name2index_map.end(); + Rprintf("0-based index: name\n"); + for(; i_n2i != end_n2i; ++i_n2i) { + Rprintf("%d: %s\n", i_n2i->first.c_str(), (int)i_n2i->second); + } + } + void set_from_list(Rcpp::List Rlist) { + Rcpp::CharacterVector Rnames = Rlist.names(); + size_t len = Rnames.length(); + for(size_t i = 0; i < len; ++i) { + // explicit cast is needed because even though Rnames[i] can cast to a string, + // set_value takes a const string& so we need an object in place here. + // set_value fails safely if a name is not found. + static_cast(this)->set_value(std::string(Rnames[i]), Rlist[i]); + } + } + void resize_from_list(Rcpp::List Rlist) { + Rcpp::CharacterVector Rnames = Rlist.names(); + size_t len = Rnames.length(); + size_t vec_len; + Rcpp::IntegerVector vs; + for(size_t i = 0; i < len; ++i) { + // explicit cast is needed because even though Rnames[i] can cast to a string, + // set_value takes a const string& so we need an object in place here. + vs = Rlist[i]; + vec_len = vs.length(); + std::unique_ptr ETA = static_cast(this)->access(std::string(Rnames[i])); + // if the name was not found, a "Problem:" message was emitted, and we skip using it here. + if(ETA) { + switch(vec_len) { + case 0 : + break; + case 1 : + ETA->template ref<1>().resize(vs[0]); + break; + case 2 : + ETA->template ref<2>().resize(vs[0], vs[1]); + break; + case 3 : + ETA->template ref<3>().resize(vs[0], vs[1], vs[2]); + break; + case 4 : + ETA->template ref<4>().resize(vs[0], vs[1], vs[2], vs[3]); + break; + case 5 : + ETA->template ref<5>().resize(vs[0], vs[1], vs[2], vs[3], vs[4]); + break; + case 6 : + ETA->template ref<6>().resize(vs[0], vs[1], vs[2], vs[3], vs[4], vs[5]); + break; + } + } + } + } +}; diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index eb6bd25..457b262 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -13,16 +13,18 @@ nCompile(instr_nClass = nimbleModel:::instr_nClass, control=list(generate_predef test <- nCompile(instr_nClass = nimbleModel:::instr_nClass) ## # ## # generate new predef/declFunBase_nC. Move to package and add -## # "#include " in the hContent +## # "#include " in the hContent +## # And add "// [[Rcpp::depends(nimbleModel)]]" to the cppContent ## # after declaration of declFunBase_nClass nCompile(nimbleModel:::declFunBase_nClass, control=list(generate_predefined=TRUE)) test <- nCompile(nimbleModel:::declFunBase_nClass) ## # ## # generate new predef/modelBase_nC. Move to package and add -## # "#include " to that file, +## # "#include " to the hContent +## # And add "// [[Rcpp::depends(nimbleModel)]]" to the cppContent ## # after the declaration of modelBase_nClass. - nCompile(modelBase_nClass = nimbleModel:::modelBase_nClass, control=list(generate_predefined=TRUE)) - test <- nCompile(nimbleModel:::modelBase_nClass) +nCompile(modelBase_nClass = nimbleModel:::modelBase_nClass, control=list(generate_predefined=TRUE)) +test <- nCompile(nimbleModel:::modelBase_nClass) ## #nCompile(instr_nClass, modelBase_nClass, declFunBase_nClass, control=list(generate_predefined=TRUE)) ## TODO: revise these tests for instrClass (flattened approach) @@ -45,7 +47,58 @@ test_that("initial tests/examples of nimble model using flattened approach", { mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) # Begin Perry - + Cmclass <- nCompile(mclass) + Cobj <- Cmclass$new() + Cobj$calculate_impl + Cobj$calculate + debug(Cobj$calculate) + Cobj$calculate('tau') + # PROBLEM, in nList_<>::set_from_list for uncompiled list input. + # I guess set_all_values should skip NULLs? Or maybe only for non-R targets? + # Give a better message than "Bad type". Pass the name? Check for NULL? + + # Next steps + # initialize the instrs from uncompiled if needed + # + + # check technique of building and copying nList(instr_nClass) as a method: + inC <- nimbleModel:::instr_nClass + test1 <- nFunction( + function(Robj = 'SEXP') { + ans <- inC$new() + cppLiteral("ans->set_all_values(Robj);") + cppLiteral("std::cout<dim<set_all_values(Robj);") +# cppLiteral("std::cout<dim< Date: Mon, 1 Jun 2026 08:27:23 -0700 Subject: [PATCH 24/32] C++ model calculate, simulate, calculateDiff, and getLogProb are in place --- nimbleModel/R/declFunBaseClass.R | 257 ++++++++---------- nimbleModel/R/modelBaseClass.R | 166 ++++++----- nimbleModel/R/nimbleModel.R | 40 ++- .../nimbleModel/{modelBase_nC => }/.DS_Store | Bin 6148 -> 6148 bytes .../declFunClass_/declFunClass_.h | 21 -- .../inst/include/nimbleModel/predef/.DS_Store | Bin 0 -> 6148 bytes .../declFunBase_nClass_copyFiles.txt | 0 .../declFunBase_nClass_cppContent.cpp | 25 +- .../declFunBase_nClass_filebase.txt | 0 .../declFunBase_nClass_hContent.h | 6 +- .../declFunBase_nClass_manifest.txt | 2 +- .../declFunBase_nClass_post_cpp_compiler.txt | 0 .../declFunBase_nClass_preamble.cpp | 0 .../predef/declFunClass_/declFunClass_.h | 98 +++++++ .../instr_nClass/instr_nClass_copyFiles.txt | 0 .../instr_nClass/instr_nClass_cppContent.cpp | 0 .../instr_nClass/instr_nClass_filebase.txt | 0 .../instr_nClass/instr_nClass_hContent.h | 0 .../instr_nClass/instr_nClass_manifest.txt | 2 +- .../instr_nClass_post_cpp_compiler.txt | 0 .../instr_nClass/instr_nClass_preamble.cpp | 0 .../modelBase_nClass_copyFiles.txt | 0 .../modelBase_nClass_cppContent.cpp | 19 +- .../modelBase_nClass_filebase.txt | 0 .../modelBase_nC/modelBase_nClass_hContent.h | 3 + .../modelBase_nClass_manifest.txt | 2 +- .../modelBase_nClass_post_cpp_compiler.txt | 0 .../modelBase_nClass_preamble.cpp | 0 .../modelClass_/modelClass_.h | 85 +++--- nimbleModel/tests/testthat/test-nimbleModel.R | 114 +++++++- 30 files changed, 525 insertions(+), 315 deletions(-) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => }/.DS_Store (88%) delete mode 100644 nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunClass_/declFunClass_.h create mode 100644 nimbleModel/inst/include/nimbleModel/predef/.DS_Store rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/declFunBase_nC/declFunBase_nClass_copyFiles.txt (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/declFunBase_nC/declFunBase_nClass_cppContent.cpp (50%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/declFunBase_nC/declFunBase_nClass_filebase.txt (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/declFunBase_nC/declFunBase_nClass_hContent.h (67%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/declFunBase_nC/declFunBase_nClass_manifest.txt (88%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/declFunBase_nC/declFunBase_nClass_preamble.cpp (100%) create mode 100644 nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/instr_nClass/instr_nClass_copyFiles.txt (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/instr_nClass/instr_nClass_cppContent.cpp (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/instr_nClass/instr_nClass_filebase.txt (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/instr_nClass/instr_nClass_hContent.h (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/instr_nClass/instr_nClass_manifest.txt (87%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/instr_nClass/instr_nClass_post_cpp_compiler.txt (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/instr_nClass/instr_nClass_preamble.cpp (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/modelBase_nC/modelBase_nClass_copyFiles.txt (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/modelBase_nC/modelBase_nClass_cppContent.cpp (66%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/modelBase_nC/modelBase_nClass_filebase.txt (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/modelBase_nC/modelBase_nClass_hContent.h (77%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/modelBase_nC/modelBase_nClass_manifest.txt (87%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/modelBase_nC/modelBase_nClass_preamble.cpp (100%) rename nimbleModel/inst/include/nimbleModel/{modelBase_nC => predef}/modelClass_/modelClass_.h (66%) diff --git a/nimbleModel/R/declFunBaseClass.R b/nimbleModel/R/declFunBaseClass.R index 09e4233..33ae37b 100644 --- a/nimbleModel/R/declFunBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -1,6 +1,70 @@ #' @export declFunBase_nClass <- nClass( classname = "declFunBase_nClass", + Rpublic = list( + calculate = function(instr) { + calc_op(instr, "calc_one") + }, + calculateDiff = function(instr) { + calc_op(instr, "calcDiff_one") + }, + getLogProb = function(instr) { + calc_op(instr, "getLogProb_one") + }, + calc_op = function(instr, fn) { + if(instr$type == 0) return(calc_0(instr, fn)) + if(instr$type == 1) return(calc_1_seq(instr, fn)) + if(instr$type == 2) return(calc_1_mat(instr, fn)) + if(instr$type == 3) return(calc_1_matp(instr, fn)) + return(0) + }, + calc_0 = function(instr, fn) { + return(self[[fn]](0)) + }, + calc_1_seq = + function(instr, fn) { + logProb = 0 + iStart <- instr$values[[1]][1] # Values seem to start offset by -1, a bit confusing + for(i in 1:instr$lens[1]) + logProb <- logProb + self[[fn]](iStart + i) + return(logProb) + }, + calc_1_mat = + function(instr, fn) { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + self[[fn]](instr$values[[1]][i]) + return(logProb) + }, + calc_1_matp = + function(instr, fn) { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + self[[fn]](instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + return(logProb) + }, + simulate = function(instr) { + if(instr$type == 0) return(sim_0(instr)) + if(instr$type == 1) return(sim_1_seq(instr)) + if(instr$type == 2) return(sim_1_mat(instr)) + if(instr$type == 3) return(sim_1_matp(instr)) + }, + sim_0 = function(instr) { + sim_one(0) ## sim_one will always has `idx` as arg? + }, + sim_1_seq = function(instr) { + for(i in 1:instr$lens[1]) + sim_one(instr$values[[1]][1]+i) + }, + sim_1_mat = function(instr) { + for(i in 1:instr$lens[1]) + sim_one(instr$values[[1]][i]) + }, + sim_1_matp = function(instr) { + for(i in 1:instr$lens[1]) + sim_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + } + ), Cpublic = list( ## model = 'modelBase_nClass', ping = nFunction( @@ -8,105 +72,57 @@ declFunBase_nClass <- nClass( function() {return(TRUE); returnType(logical())}, compileInfo = list(virtual=TRUE) ), + calculate_cpp = nFunction( + name = "calculate_cpp", + function(instr) { + stop("Uncompiled version of calculate_cpp should not be called.") + }, + returnType = 'numericScalar', + compileInfo = list(virtual=TRUE, + C_fun = function(instr = 'instr_nClass') { + cppLiteral('Rprintf("declFunBase_nClass virtual base calculate_cpp should never be called (something is wrong)\\n");') + return(0) + }) + ), + calculateDiff_cpp = nFunction( + name = "calculateDiff_cpp", + function(instr) { + stop("Uncompiled version of calculateDiff_cpp should not be called.") + }, + returnType = 'numericScalar', + compileInfo = list(virtual=TRUE, + C_fun = function(instr = 'instr_nClass') { + cppLiteral('Rprintf("declFunBase_nClass virtual base calculateDiff_cpp should never be called (something is wrong)\\n");') + return(0) + }) + ), + getLogProb_cpp = nFunction( + name = "getLogProb_cpp", + function(instr) { + stop("Uncompiled version of getLogProb_cpp should not be called.") + }, + returnType = 'numericScalar', + compileInfo = list(virtual=TRUE, + C_fun = function(instr = 'instr_nClass') { + cppLiteral('Rprintf("declFunBase_nClass virtual base getLogProb_cpp should never be called (something is wrong)\\n");') + return(0) + }) + ), + simulate_cpp = nFunction( + name = "simulate_cpp", + function(instr) { + stop("Uncompiled version of simulate_cpp should not be called.") + }, + returnType = 'void', + compileInfo = list(virtual=TRUE, + C_fun = function(instr = 'instr_nClass') { + cppLiteral('Rprintf("declFunBase_nClass virtual base simulate_cpp should never be called (something is wrong)\\n");') + }) + ) + + - calculate = nFunction( - name = "calculate", - fun = function(instr = 'instr_nClass') { - ## TODO: how embed determination of vec and parallel cases here? - if(instr$type == 0) return(calc_0(instr)) - # if(instr$type == 1) return(calc_1_seq(instr)) - # if(instr$type == 2) return(calc_1_mat(instr)) - # if(instr$type == 3) return(calc_1_matp(instr)) - return(0) ## Need to error trap/warn if unhandled type requested - }, returnType = 'numericScalar', - compileInfo = list(virtual=TRUE) - ), - calc_0 = nFunction( - name = 'calc_0', - function(instr = 'instr_nClass') { - return(calc_one(0)) ## calc_one will always has `idx` as arg? - }, - returnType = 'numericScalar', - compileInfo = list( - C_fun = function(instr = 'instr_nClass') { - cppLiteral('Rprintf("declFunBase_nClass calc_0 (should not see this)\\n");'); return(0) - }, - virtual=TRUE - ) - )#, - # calc_1_seq = nFunction( - # name = 'calc_1_seq', - # function(instr = 'instr_nClass') { - # logProb = 0 - # for(i in 1:instr$lens[1]) - # logProb <- logProb + calc_one(instr$values[[1]][1]+i) - # return(logProb) - # }, returnType = 'numericScalar' - # ), - # calc_1_mat = nFunction( - # name = 'calc_1_mat', - # function(instr = 'instr_nClass') { - # logProb = 0 - # for(i in 1:instr$lens[1]) - # logProb <- logProb + calc_one(instr$values[[1]][i]) - # return(logProb) - # }, returnType = 'numericScalar' - # ), - # calc_1_matp = nFunction( - # name = 'calc_1_mat', - # function(instr = 'instr_nClass') { - # logProb = 0 - # for(i in 1:instr$lens[1]) - # logProb <- logProb + calc_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? - # return(logProb) - # }, returnType = 'numericScalar' - # ), - - # calculateDiff = nFunction( - # name = "calculateDiff", - # fun = function(instr = 'instr_nClass') { - # ## TODO: how embed determination of vec and parallel cases here? - # if(instr$type == 0) return(calcDiff_0(instr)) - # if(instr$type == 1) return(calcDiff_1_seq(instr)) - # if(instr$type == 2) return(calcDiff_1_mat(instr)) - # if(instr$type == 3) return(calcDiff_1_matp(instr)) - # return(0) ## Need to error trap/warn if unhandled type requested - # }, returnType = 'numericScalar', - # compileInfo = list(virtual=TRUE) - # ), - # calcDiff_0 = nFunction( - # name = 'calcDiff_0', - # function(instr = 'instr_nClass') { - # return(calcDiff_one(0)) ## calcDiff_one will always has `idx` as arg? - # }, returnType = 'numericScalar' - # ), - # calcDiff_1_seq = nFunction( - # name = 'calcDiff_1_seq', - # function(instr = 'instr_nClass') { - # logProb = 0 - # for(i in 1:instr$lens[1]) - # logProb <- logProb + calcDiff_one(instr$values[[1]][1]+i) - # return(logProb) - # }, returnType = 'numericScalar' - # ), - # calcDiff_1_mat = nFunction( - # name = 'calcDiff_1_mat', - # function(instr = 'instr_nClass') { - # logProb = 0 - # for(i in 1:instr$lens[1]) - # logProb <- logProb + calcDiff_one(instr$values[[1]][i]) - # return(logProb) - # }, returnType = 'numericScalar' - # ), - # calcDiff_1_matp = nFunction( - # name = 'calcDiff_1_mat', - # function(instr = 'instr_nClass') { - # logProb = 0 - # for(i in 1:instr$lens[1]) - # logProb <- logProb + calcDiff_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? - # return(logProb) - # }, returnType = 'numericScalar' - # ), + # simulate = nFunction( # name = "simulate", @@ -147,51 +163,6 @@ declFunBase_nClass <- nClass( # } # ), - # getLogProb = nFunction( - # name = "getLogProb", - # fun = function(instr = 'instr_nClass') { - # ## TODO: how embed determination of vec and parallel cases here? - # if(instr$type == 0) return(getLogProb_0(instr)) - # if(instr$type == 1) return(getLogProb_1_seq(instr)) - # if(instr$type == 2) return(getLogProb_1_mat(instr)) - # if(instr$type == 3) return(getLogProb_1_matp(instr)) - # return(0) ## Need to error trap/warn if unhandled type requested - # }, returnType = 'numericScalar', - # compileInfo = list(virtual=TRUE) - # ), - # getLogProb_0 = nFunction( - # name = 'getLogProb_0', - # function(instr = 'instr_nClass') { - # return(getLogProb_one(0)) ## getLogProb_one will always has `idx` as arg? - # }, returnType = 'numericScalar' - # ), - # getLogProb_1_seq = nFunction( - # name = 'getLogProb_1_seq', - # function(instr = 'instr_nClass') { - # logProb = 0 - # for(i in 1:instr$lens[1]) - # logProb <- logProb + getLogProb_one(instr$values[[1]][1]+i) - # return(logProb) - # }, returnType = 'numericScalar' - # ), - # getLogProb_1_mat = nFunction( - # name = 'getLogProb_1_mat', - # function(instr = 'instr_nClass') { - # logProb = 0 - # for(i in 1:instr$lens[1]) - # logProb <- logProb + getLogProb_one(instr$values[[1]][i]) - # return(logProb) - # }, returnType = 'numericScalar' - # ), - # getLogProb_1_matp = nFunction( - # name = 'getLogProb_1_mat', - # function(instr = 'instr_nClass') { - # logProb = 0 - # for(i in 1:instr$lens[1]) - # logProb <- logProb + getLogProb_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? - # return(logProb) - # }, returnType = 'numericScalar' - # ) ), ## We haven't dealt with ensuring a virtual destructor when any method is virtual diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 87efdca..15d3ee9 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -18,7 +18,9 @@ modelBase_nClass <- nClass( declFunNames <- names(declFunNameToIndex) if(isCompiled()) { - self$setup_decl_mgmt_from_names(declFunNames) + # self$setup_decl_mgmt_from_names(declFunNames) + # setting up the canonically indexed vector of node functions + # now happens in the C++ constructor. } else { self$declFunList <- list() length(self$declFunList) <- length(declFunNames) @@ -86,55 +88,46 @@ modelBase_nClass <- nClass( includePredictive, predictiveOnly, includeRHSonly, topOnly, latentOnly, endOnly) }, - calculate = function(input) { - if(missing(input)) - input <- getVarNames() - instrList <- makeInstrList(self,input) + calc_op = function(instr, fn, fn_cpp) { + if(missing(instr)) + instr <- getVarNames() + instrList <- makeInstrList(self,instr) if(isCompiled()) { if(!instrList$isCompiled()) instrList <- makeCompiledInstrList(instrList) - return(calculate_impl(instrList)) + return(self[[fn_cpp]](instrList)) } logProb <- 0 for(i in 1:length(instrList)) { - logProb <- logProb + declFunList[[instrList[[i]]$declID]]$calculate(instrList[[i]]) + logProb <- logProb + declFunList[[instrList[[i]]$declID]][[fn]](instrList[[i]]) } return(logProb) - }#, - # calculateDiff = function(input) { - # if(missing(input)) - # input <- getVarNames() - # instrList <- makeInstrList(self, input) - # if(isCompiled()) - # return(calculateDiff_impl(instrList)) - # logProb <- 0 - # for(i in 1:length(instrList)) { - # logProb <- logProb + declFunList[[instrList[[i]]$declID]]$calculateDiff(instrList[[i]]) - # } - # return(logProb) - # }, - # simulate = function(input) { - # if(missing(input)) - # input <- getVarNames() - # instrList <- makeInstrList(self, input) - # if(isCompiled()) { - # simulate_impl(instrList) - # } else - # for(i in 1:length(instrList)) { - # declFunList[[instrList[[i]]$declID]]$simulate(instrList[[i]]) - # } - # }, - # getLogProb = function(input) { - # if(missing(input)) - # input <- getVarNames() - # instrList <- makeInstrList(self, input) - # if(isCompiled()) - # return(getLogProb_impl(instrList)) - # logProb <- 0 - # for(i in 1:length(instrList)) { - # logProb <- logProb + declFunList[[instrList[[i]]$declID]]$getLogProb(instrList[[i]]) - # } - # return(logProb) - # } + }, + calculate = function(instr) { + logProb <- calc_op(instr, "calculate", "calculate_impl") + return(logProb) + }, + calculateDiff = function(instr) { + logProb <- calc_op(instr, "calculateDiff", "calculateDiff_impl") + return(logProb) + }, + getLogProb = function(instr) { + logProb <- calc_op(instr, "getLogProb", "getLogProb_impl") + return(logProb) + }, + simulate = function(instr) { + if(missing(instr)) + instr <- getVarNames() + instrList <- makeInstrList(self,instr) + if(isCompiled()) { + if(!instrList$isCompiled()) instrList <- makeCompiledInstrList(instrList) + self$simulate_impl(instrList) + } else { + for(i in 1:length(instrList)) { + declFunList[[instrList[[i]]$declID]]$simulate(instrList[[i]]) + } + } + return(invisible(NULL)) + } ), Cpublic = list( ## TODO: using 'RcppObject' was resulting in a symbolTBD error - probably nCompiler issue 186. @@ -168,47 +161,52 @@ modelBase_nClass <- nClass( }, virtual=TRUE ) - )#, - # calculateDiff_impl = nFunction( - # name = "calculateDiff_impl", - # function(instrList) { - # cat("Uncompiled `calculateDiff_impl` should never be called.\n") - # return(0) - # }, - # returnType = 'numericScalar', - # compileInfo = list( - # C_fun = function(instrList = 'nList(instr_nClass)') { - # ## NOTE: instrList input will be ordered. - # cppLiteral('modelClass_::calculateDiff(instrList);') - # }, - # virtual=TRUE - # ) - # ), - # simulate_impl = nFunction( - # name = "simulate_impl", - # function(instrList) { - # cat("Uncompiled `simulate_impl` should never be called.\n") - # }, - # compileInfo = list( - # C_fun = function(instrList = 'nList(instr_nClass)') { - # cppLiteral('modelClass_::simulate(instrList);') - # }, - # virtual=TRUE - # ) - # ), - # getLogProb_impl = nFunction( - # name = "getLogProb_impl", - # function(instrList) { - # cat("Uncompiled `getLogProb_impl` should never be called.\n") - # }, - # returnType = 'numericScalar', - # compileInfo = list( - # C_fun = function(instrList = 'nList(instr_nClass)') { - # cppLiteral('modelClass_::getLogProb(instrList);') - # }, - # virtual=TRUE - # ) - # ) + ), + calculateDiff_impl = nFunction( + name = "calculateDiff_impl", + function(instrList) { + cat("Uncompiled `calculateDiff_impl` should never be called.\n") + return(0) + }, + returnType = 'numericScalar', + compileInfo = list( + C_fun = function(instrList = 'nList(instr_nClass)') { + ## NOTE: instrList input will be ordered. + cppLiteral('Rprintf("modelBase_nClass calculateDiff_impl (should not see this)\\n");'); return(0) + }, + virtual=TRUE + ) + ), + getLogProb_impl = nFunction( + name = "getLogProb_impl", + function(instrList) { + cat("Uncompiled `getLogProb_impl` should never be called.\n") + return(0) + }, + returnType = 'numericScalar', + compileInfo = list( + C_fun = function(instrList = 'nList(instr_nClass)') { + ## NOTE: instrList input will be ordered. + cppLiteral('Rprintf("modelBase_nClass getLogProb_impl (should not see this)\\n");'); return(0) + }, + virtual=TRUE + ) + ), + simulate_impl = nFunction( + name = "simulate_impl", + function(instrList) { + cat("Uncompiled `simulate_impl` should never be called.\n") + return(invisible(NULL)) + }, + returnType = 'void', + compileInfo = list( + C_fun = function(instrList = 'nList(instr_nClass)') { + ## NOTE: instrList input will be ordered. + cppLiteral('Rprintf("modelBase_nClass simulate_impl (should not see this)\\n");'); + }, + virtual=TRUE + ) + ) ), ## See comment above about needing to ensure a virtual destructor predefined = quote(system.file(file.path("include","nimbleModel", "predef"), package="nimbleModel") |> file.path("modelBase_nC")), diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index f8e2336..6ec1889 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/nimbleModel/R/nimbleModel.R @@ -47,6 +47,11 @@ make_modelClass_from_nimbleModel <- function(m, compile=FALSE) { assign(declFun_RvarName, make_declFun_nClass(declVarInfo, decl_methods, declFun_classname, declID)) declInfoList[[i]] <- make_decl_info_for_model_nClass(declFun_membername, declFun_RvarName, declFun_classname, declVarInfo) } + ## We have a canonical ordering of decls, but it does arise from a couple of places that should match. + # so we check here. + ordered_decl_names <- lapply(declInfoList, function(x) x$membername) |> unlist() + if(!identical(ordered_decl_names, names(mDef$declFunNameToIndex))) + stop("declaration ordering in declInfoList does not matchdeclFunNameToIndex") modelClassInstance <- makeModel_nClass(modelVarInfo, declInfoList, inits = m$origInits, data = m$origData, model = m, classname = "my_model", env = environment()) } @@ -196,13 +201,13 @@ makeModel_nClass <- function(modelVarInfo, names(CpublicModelVars) <- modelVarInfo$vars |> lapply(\(x) x$name) |> unlist() opDefs <- list( base_ping = nCompiler:::getOperatorDef("custom_call"), - setup_decl_mgmt = nCompiler:::getOperatorDef("custom_call"), + setup_auto_decl_mgmt = nCompiler:::getOperatorDef("custom_call"), do_setup_decl_mgmt_from_names = nCompiler:::getOperatorDef("custom_call") ) opDefs$base_ping$returnType <- nCompiler:::type2symbol(quote(void())) # How can this be passed into nClass? opDefs$base_ping$labelAbstractTypes$recurse <- FALSE - opDefs$setup_decl_mgmt$returnType <- nCompiler:::type2symbol(quote(void())) - opDefs$setup_decl_mgmt$labelAbstractTypes$recurse <- FALSE + opDefs$setup_auto_decl_mgmt$returnType <- nCompiler:::type2symbol(quote(void())) + opDefs$setup_auto_decl_mgmt$labelAbstractTypes$recurse <- FALSE opDefs$do_setup_decl_mgmt_from_names$returnType <- nCompiler:::type2symbol(quote(void())) opDefs$do_setup_decl_mgmt_from_names$labelAbstractTypes$recurse <- FALSE @@ -210,11 +215,11 @@ makeModel_nClass <- function(modelVarInfo, classname <- modelLabelCreator() CpublicMethods <- list( - do_setup_decl_mgmt = nFunction( - name = "call_setup_decl_mgmt", + do_setup_auto_decl_mgmt = nFunction( + name = "call_setup_auto_decl_mgmt", function() {}, compileInfo=list( - C_fun = function() {setup_decl_mgmt()}) + C_fun = function() {setup_auto_decl_mgmt()}) ), setup_decl_mgmt_from_names = nFunction( name = "call_setup_decl_mgmt_from_names", @@ -252,19 +257,32 @@ makeModel_nClass <- function(modelVarInfo, init_string = init_string) }) - CpublicDeclFuns <- decl_pieces |> lapply(\(x) x$nClass_type) |> setNames(names(model$modelDef$declFunNameToIndex)) + declFunNameToIndex <- model$modelDef$declFunNameToIndex + + CpublicDeclFuns <- decl_pieces |> lapply(\(x) x$nClass_type) |> setNames(names(declFunNameToIndex)) # CpublicDeclFuns <- list( # beta_decl = 'decl_dnorm()' # ) CpublicCtor <- list( nFunction( - function(){}, + function(){ + cppLiteral("setup_decl_mgmt();") # This will be the default but can be overridden by decls that need to do something special. We could also have a version that takes decl names as input and only sets up those. + }, compileInfo = list(constructor=TRUE, #initializers = c('nCpp("beta_decl(new decl_dnorm(mu, beta, 1))")')) initializers = decl_pieces |> lapply(\(x) x$init_string) |> unlist()) ) ) |> structure(names = classname) + declFunPtrsSetupLiterals <- paste0("declFunPtrs[(", as.integer(declFunNameToIndex) , ")-1] = ", names(declFunNameToIndex)) + declFunPtrsResizeLiteral <- paste0("declFunPtrs.resize(", length(declFunNameToIndex) , ")") + setup_decl_mgmt_body <- as.list(c(declFunPtrsResizeLiteral, declFunPtrsSetupLiterals)) |> + lapply(\(x) substitute(nCpp(X), list(X = x))) + setup_decl_mgmt_fun <- function() {} + for(i in seq_along(setup_decl_mgmt_body)) + body(setup_decl_mgmt_fun)[[i+1]] <- setup_decl_mgmt_body[[i]] + Cpublic_setup_decl_mgmt <- list(setup_decl_mgmt = nFunction(name = "setup_decl_mgmt", fun = setup_decl_mgmt_fun)) + baseclass <- paste0("modelClass_<", classname, ">") # CpublicDeclFuns has elements like "decl_1 = quote(declFxn_1())" # We provide it in Cpublic to declare C++ member variables with types. @@ -287,7 +305,7 @@ makeModel_nClass <- function(modelVarInfo, list(OPDEFS = opDefs, # A list of individual elements RPUBLIC = list( - declFunNameToIndex_ = model$modelDef$declFunNameToIndex, + declFunNameToIndex_ = model$modelDef$declFunNameToIndex, defaultSizes = modelVarInfo$sizes, defaultInits = inits, defaultData = data, @@ -298,7 +316,7 @@ makeModel_nClass <- function(modelVarInfo, nonpredictiveRules = model$nonpredictiveRules, CpublicDeclFuns = CpublicDeclFuns), # A concatenation of lists - CPUBLIC = c(CpublicDeclFuns, CpublicModelVars, CpublicCtor, CpublicMethods), + CPUBLIC = c(CpublicDeclFuns, Cpublic_setup_decl_mgmt, CpublicModelVars, CpublicCtor, CpublicMethods), CLASSNAME = classname, BASECLASS = baseclass) ) @@ -476,5 +494,3 @@ make_decl_methods_from_declInfo <- function(declInfo) { } methodList } - - diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/.DS_Store b/nimbleModel/inst/include/nimbleModel/.DS_Store similarity index 88% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/.DS_Store rename to nimbleModel/inst/include/nimbleModel/.DS_Store index a39061b8ebb30b64ba5c9d872536be6251fcf2a6..c4c1caa1013374a9398c15e3ffbfbc0f7969916d 100644 GIT binary patch delta 212 zcmZoMXfc=|#>B`mu~2NHo}wrV0|Nsi1A_nqLn=dBPP$=ma(-^X#KPtEAPF{x0)`@> zL<+JbP#gwO;4iMSG3;>g1GOGXp literal 6148 zcmeHKu};H44E2=`sam0qu-z~84?+kmNC?r90ccaT5(%k~T&jdZdKz>8asu zhQG)F-`yc)G@~iyRKLF&-Qq4!^Z95zEsLcjKe*oIUzBM&$;%1+qL=5(o8!0Flie}d zuVa>rdR|wY-hc`!!&!3u4Yr=4|NfnCJ^zo3-h<}9b?>75%Kaz)EqQb9CdPmSKprT7RM1a{98V60dP!UC~B0)Yk_ JjDfu}@ChpJUdI3c diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunClass_/declFunClass_.h b/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunClass_/declFunClass_.h deleted file mode 100644 index 0c26dfe..0000000 --- a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunClass_/declFunClass_.h +++ /dev/null @@ -1,21 +0,0 @@ -// to be included from the predefined nodeFxnBase_nClass. -// Add "#include " to that file, -// after the declaration of nodeFxnBase_nClass. - -template -class declFunClass_ : public declFunBase_nClass { -public: - double v; - declFunClass_() {}; - - double calculate ( std::shared_ptr nodeInstr ) override { -RESET_EIGEN_ERRORS -double logProb(0.0); -// const auto& methodInstr = nodeInstr->methodInstr; -// const auto& indsInstrVec = nodeInstr->indsInstrVec; -// logProb += static_cast(this)->calc_one((*indsInstrVec)[0]); -return(logProb); - } - - virtual ~declFunClass_() {}; -}; diff --git a/nimbleModel/inst/include/nimbleModel/predef/.DS_Store b/nimbleModel/inst/include/nimbleModel/predef/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..dead564f3a3448bd60ad9581a43d10420182f518 GIT binary patch literal 6148 zcmeHKy-ve05I&a*6t?ns6!Qe(7)e0l<`|G_t5zMa$9*LiIcy@@Y%6tE&%iJDN3SCP2tAFbDLdUNr- zz%}$4KL|S&43`n-PwOva-~bhG!U-I+_8kTp)p?Ju-){%6a^4un)_K3JjUB3aW{mH_JFW3H&XvU}WNnDl zInS2bXEUs|F}gEH21m#FI!NNj4fkxaRGQKDRspMkRp3(rS|1#2gs#GfQ7#?W$s+(_ z65Z19TJB|t4ml8Ag%Klq&;+LcT}9KFk<9%5c179j(W3DCln#yj($gm zgK!ybZxyf##1$Cf+br$>%jWZcJjvc!1*`)9N&%7die4T|QhRGxakSSu*mkgyQC!3* mQ?OIpvAm$Icn+I1eCE&vqN^}sL=T$%5s)(2&MNS$3cLec-rJY} literal 0 HcmV?d00001 diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_copyFiles.txt b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_copyFiles.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_copyFiles.txt rename to nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_copyFiles.txt diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_cppContent.cpp b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_cppContent.cpp similarity index 50% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_cppContent.cpp rename to nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_cppContent.cpp index 115eab4..fdc948f 100644 --- a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_cppContent.cpp +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_cppContent.cpp @@ -11,24 +11,31 @@ using namespace Rcpp; // [[Rcpp::plugins(nCompiler_Eigen_plugin)]] // [[Rcpp::depends(RcppParallel)]] // [[Rcpp::depends(nCompiler)]] -// [[Rcpp::depends(nimbleModel)]] // [[Rcpp::depends(Rcereal)]] +// [[Rcpp::depends(nimbleModel)]] bool declFunBase_nClass::ping ( ) { RESET_EIGEN_ERRORS return(true); } - double declFunBase_nClass::calculate ( std::shared_ptr instr ) { + double declFunBase_nClass::calculate_cpp ( std::shared_ptr instr ) { RESET_EIGEN_ERRORS -if((instr)->type==0.0) { - return(calc_0(instr)); +Rprintf("declFunBase_nClass virtual base calculate_cpp should never be called (something is wrong)\n");; +return(0.0); } + double declFunBase_nClass::calculateDiff_cpp ( std::shared_ptr instr ) { +RESET_EIGEN_ERRORS +Rprintf("declFunBase_nClass virtual base calculateDiff_cpp should never be called (something is wrong)\n");; return(0.0); } - double declFunBase_nClass::calc_0 ( std::shared_ptr instr ) { + double declFunBase_nClass::getLogProb_cpp ( std::shared_ptr instr ) { RESET_EIGEN_ERRORS -Rprintf("declFunBase_nClass calc_0 (should not see this)\n");; +Rprintf("declFunBase_nClass virtual base getLogProb_cpp should never be called (something is wrong)\n");; return(0.0); +} + void declFunBase_nClass::simulate_cpp ( std::shared_ptr instr ) { +RESET_EIGEN_ERRORS +Rprintf("declFunBase_nClass virtual base simulate_cpp should never be called (something is wrong)\n");; } declFunBase_nClass::declFunBase_nClass ( ) { RESET_EIGEN_ERRORS @@ -51,8 +58,10 @@ declFunBase_nClass, NCOMPILER_FIELDS(), NCOMPILER_METHODS( method("ping", &declFunBase_nClass::ping, args({{}})), -method("calculate", &declFunBase_nClass::calculate, args({{arg("instr",copy)}})), -method("calc_0", &declFunBase_nClass::calc_0, args({{arg("instr",copy)}})) +method("calculate_cpp", &declFunBase_nClass::calculate_cpp, args({{arg("instr",copy)}})), +method("calculateDiff_cpp", &declFunBase_nClass::calculateDiff_cpp, args({{arg("instr",copy)}})), +method("getLogProb_cpp", &declFunBase_nClass::getLogProb_cpp, args({{arg("instr",copy)}})), +method("simulate_cpp", &declFunBase_nClass::simulate_cpp, args({{arg("instr",copy)}})) ) ) #endif diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_filebase.txt b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_filebase.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_filebase.txt rename to nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_filebase.txt diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_hContent.h b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_hContent.h similarity index 67% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_hContent.h rename to nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_hContent.h index 2cdb615..fe06f27 100644 --- a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_hContent.h +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_hContent.h @@ -11,8 +11,10 @@ class declFunBase_nClass : public interface_resolver< genericInterfaceC >, public loadedObjectHookC { public: virtual bool ping ( ) ; - virtual double calculate ( std::shared_ptr instr ) ; - virtual double calc_0 ( std::shared_ptr instr ) ; + virtual double calculate_cpp ( std::shared_ptr instr ) ; + virtual double calculateDiff_cpp ( std::shared_ptr instr ) ; + virtual double getLogProb_cpp ( std::shared_ptr instr ) ; + virtual void simulate_cpp ( std::shared_ptr instr ) ; declFunBase_nClass ( ) ; }; diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_manifest.txt b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_manifest.txt similarity index 88% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_manifest.txt rename to nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_manifest.txt index 9d2ef84..72394be 100644 --- a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_manifest.txt +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_manifest.txt @@ -1,4 +1,4 @@ -list(saved_at = structure(1780087606.61385, class = c("POSIXct", +list(saved_at = structure(1780285145.92737, class = c("POSIXct", "POSIXt")), packet_name = "declFunBase_nClass", elements = c("preamble", "cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" ), files = list(preamble = "declFunBase_nClass_preamble.cpp", diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt rename to nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_post_cpp_compiler.txt diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_preamble.cpp b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_preamble.cpp similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/declFunBase_nC/declFunBase_nClass_preamble.cpp rename to nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_preamble.cpp diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h new file mode 100644 index 0000000..627cf9b --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h @@ -0,0 +1,98 @@ +// to be included from the predefined nodeFxnBase_nClass. +// Add "#include " to that file, +// after the declaration of nodeFxnBase_nClass. + +template +class declFunClass_ : public declFunBase_nClass { +public: + double v; + declFunClass_() {}; + + double calculate_cpp( std::shared_ptr instr) override { + return calc_op_< &Derived::calc_one >(instr); + } + double calculateDiff_cpp( std::shared_ptr instr) override { + return calc_op_< &Derived::calcDiff_one >(instr); + } + double getLogProb_cpp( std::shared_ptr instr) override { + return calc_op_< &Derived::getLogProb_one >(instr); + } + template + double calc_op_ ( std::shared_ptr instr ) { + RESET_EIGEN_ERRORS; + int instr_type = instr->type; + if(instr_type == 0) return calc_0_< Method >(instr); + if(instr_type == 1) return calc_1_seq_< Method >(instr); + if(instr_type == 2) return calc_1_mat_< Method >(instr); + return(0); + } + template + double calc_0_ (std::shared_ptr instr) { + return( (static_cast(this)->*Method)(instr->lens) ); // lens serves as a dummy here, to have the right type to pass + } + template + double calc_1_seq_(std::shared_ptr instr) { + int len = instr->lens[0]; + if(len < 1) return(0); + int iStart = instr->values->operator[](0)[0] + 1; + int iEnd = iStart + len; + Eigen::Tensor idx(1); + double logProb(0.); + for(int i = iStart; i < iEnd; ++i) { + idx[0] = i; + logProb += (static_cast(this)->*Method)(idx); + } + return(logProb); + } + template + double calc_1_mat_(std::shared_ptr instr) { + int len = instr->lens[0]; + const auto& vals = instr->values->operator[](0); + if(len != vals.size()) std::cout<<"len != vals.size() in calc_1_mat_"< idx(1); + double logProb(0.); + for(int i = 0; i < len; ++i) { + idx[0] = vals[i]; + logProb += (static_cast(this)->*Method)(idx); + } + return(logProb); + } + // simulate + void simulate_cpp ( std::shared_ptr instr ) { + RESET_EIGEN_ERRORS; + int instr_type = instr->type; + if(instr_type == 0) return sim_0_(instr); + if(instr_type == 1) return sim_1_seq_(instr); + if(instr_type == 2) return sim_1_mat_(instr); + } + void sim_0_ (std::shared_ptr instr) { + static_cast(this)->sim_one(instr->lens); // lens serves as a dummy here, to have the right type to pass + } + void sim_1_seq_(std::shared_ptr instr) { + int len = instr->lens[0]; + if(len < 1) return; + int iStart = instr->values->operator[](0)[0] + 1; + int iEnd = iStart + len; + Eigen::Tensor idx(1); + for(int i = iStart; i < iEnd; ++i) { + idx[0] = i; + static_cast(this)->sim_one(idx); + } + } + void sim_1_mat_(std::shared_ptr instr) { + int len = instr->lens[0]; + const auto& vals = instr->values->operator[](0); + if(len != vals.size()) std::cout<<"len != vals.size() in sim_1_mat_"< idx(1); + for(int i = 0; i < len; ++i) { + idx[0] = vals[i]; + static_cast(this)->sim_one(idx); + } + } + + + + virtual ~declFunClass_() {}; +}; diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_copyFiles.txt b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_copyFiles.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_copyFiles.txt rename to nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_copyFiles.txt diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_cppContent.cpp b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_cppContent.cpp rename to nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_filebase.txt b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_filebase.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_filebase.txt rename to nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_filebase.txt diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_hContent.h b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_hContent.h rename to nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_manifest.txt b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_manifest.txt similarity index 87% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_manifest.txt rename to nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_manifest.txt index ad88dd7..a3aa3c2 100644 --- a/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_manifest.txt +++ b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_manifest.txt @@ -1,4 +1,4 @@ -list(saved_at = structure(1780186830.15166, class = c("POSIXct", +list(saved_at = structure(1780285129.29081, class = c("POSIXct", "POSIXt")), packet_name = "instr_nClass", elements = c("preamble", "cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" ), files = list(preamble = "instr_nClass_preamble.cpp", cppContent = "instr_nClass_cppContent.cpp", diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_post_cpp_compiler.txt b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_post_cpp_compiler.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_post_cpp_compiler.txt rename to nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_post_cpp_compiler.txt diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_preamble.cpp b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_preamble.cpp similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/instr_nClass/instr_nClass_preamble.cpp rename to nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_preamble.cpp diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_copyFiles.txt b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_copyFiles.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_copyFiles.txt rename to nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_copyFiles.txt diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_cppContent.cpp b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_cppContent.cpp similarity index 66% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_cppContent.cpp rename to nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_cppContent.cpp index c54588c..d545f78 100644 --- a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_cppContent.cpp +++ b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_cppContent.cpp @@ -29,6 +29,20 @@ return(ans); RESET_EIGEN_ERRORS Rprintf("modelBase_nClass calculate_impl (should not see this)\n");; return(0.0); +} + double modelBase_nClass::calculateDiff_impl ( std::shared_ptr instrList ) { +RESET_EIGEN_ERRORS +Rprintf("modelBase_nClass calculateDiff_impl (should not see this)\n");; +return(0.0); +} + double modelBase_nClass::getLogProb_impl ( std::shared_ptr instrList ) { +RESET_EIGEN_ERRORS +Rprintf("modelBase_nClass getLogProb_impl (should not see this)\n");; +return(0.0); +} + void modelBase_nClass::simulate_impl ( std::shared_ptr instrList ) { +RESET_EIGEN_ERRORS +Rprintf("modelBase_nClass simulate_impl (should not see this)\n");; } modelBase_nClass::modelBase_nClass ( ) { RESET_EIGEN_ERRORS @@ -55,7 +69,10 @@ field("declFunNameToIndex", &modelBase_nClass::declFunNameToIndex) NCOMPILER_METHODS( method("ping", &modelBase_nClass::ping, args({{}})), method("makeCompiledInstrList", &modelBase_nClass::makeCompiledInstrList, args({{arg("input",copy)}})), -method("calculate_impl", &modelBase_nClass::calculate_impl, args({{arg("instrList",copy)}})) +method("calculate_impl", &modelBase_nClass::calculate_impl, args({{arg("instrList",copy)}})), +method("calculateDiff_impl", &modelBase_nClass::calculateDiff_impl, args({{arg("instrList",copy)}})), +method("getLogProb_impl", &modelBase_nClass::getLogProb_impl, args({{arg("instrList",copy)}})), +method("simulate_impl", &modelBase_nClass::simulate_impl, args({{arg("instrList",copy)}})) ) ) #endif diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_filebase.txt b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_filebase.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_filebase.txt rename to nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_filebase.txt diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_hContent.h b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_hContent.h similarity index 77% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_hContent.h rename to nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_hContent.h index 3a47468..6422f2a 100644 --- a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_hContent.h +++ b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_hContent.h @@ -15,6 +15,9 @@ class modelBase_nClass : public interface_resolver< genericInterfaceC makeCompiledInstrList ( SEXP input ) ; virtual double calculate_impl ( std::shared_ptr instrList ) ; + virtual double calculateDiff_impl ( std::shared_ptr instrList ) ; + virtual double getLogProb_impl ( std::shared_ptr instrList ) ; + virtual void simulate_impl ( std::shared_ptr instrList ) ; modelBase_nClass ( ) ; double declFunList; Rcpp::List declFunNameToIndex; diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_manifest.txt b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_manifest.txt similarity index 87% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_manifest.txt rename to nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_manifest.txt index 36cdfdd..01c4ca6 100644 --- a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_manifest.txt +++ b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_manifest.txt @@ -1,4 +1,4 @@ -list(saved_at = structure(1780261611.74136, class = c("POSIXct", +list(saved_at = structure(1780285516.41106, class = c("POSIXct", "POSIXt")), packet_name = "modelBase_nClass", elements = c("preamble", "cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" ), files = list(preamble = "modelBase_nClass_preamble.cpp", cppContent = "modelBase_nClass_cppContent.cpp", diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt rename to nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_preamble.cpp b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_preamble.cpp similarity index 100% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/modelBase_nC/modelBase_nClass_preamble.cpp rename to nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_preamble.cpp diff --git a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelClass_/modelClass_.h b/nimbleModel/inst/include/nimbleModel/predef/modelClass_/modelClass_.h similarity index 66% rename from nimbleModel/inst/include/nimbleModel/modelBase_nC/modelClass_/modelClass_.h rename to nimbleModel/inst/include/nimbleModel/predef/modelClass_/modelClass_.h index 69f5b8a..04db667 100644 --- a/nimbleModel/inst/include/nimbleModel/modelBase_nC/modelClass_/modelClass_.h +++ b/nimbleModel/inst/include/nimbleModel/predef/modelClass_/modelClass_.h @@ -7,33 +7,51 @@ template class modelClass_ : public modelBase_nClass { public: modelClass_() {}; - std::vector< std::shared_ptr > nodeFxnPtrs; + std::vector< std::shared_ptr > declFunPtrs; std::map name2index_map; - double calculate_impl(std::shared_ptr calcInstrList) override { - double logProb(0.0); - // const auto& calcInstrVec = calcInstrList->contents(); - // auto calcInstr = calcInstrVec.cbegin(); - // auto calcInstrEnd = calcInstrVec.cend(); - // for( ; calcInstr != calcInstrEnd; ++calcInstr) { - // auto nodeFxnPtr = nodeFxnPtrs[(*calcInstr)->nodeIndex-1]; - // const auto& nodeInstrVec = (*calcInstr)->nodeInstrVec->contents(); - // auto nodeInstr = nodeInstrVec.cbegin(); - // auto nodeInstrEnd = nodeInstrVec.cend(); - // for( ; nodeInstr != nodeInstrEnd; ) { - // logProb += nodeFxnPtr->calculate(*nodeInstr++); - // } + double calculate_impl(std::shared_ptr instrList) override { + // double logProb(0.0); + // const auto& instrVec = instrList->contents(); + // for (const auto& instr : instrVec) { + // logProb += declFunPtrs[instr->declID - 1 ]->calculate_cpp(instr); // } + // return(logProb); + return calc_op_impl< &declFunBase_nClass::calculate_cpp >(instrList); + } + double calculateDiff_impl(std::shared_ptr instrList) override { + return calc_op_impl< &declFunBase_nClass::calculateDiff_cpp >(instrList); + } + double getLogProb_impl(std::shared_ptr instrList) override { + return calc_op_impl< &declFunBase_nClass::getLogProb_cpp >(instrList); + } + + template + double calc_op_impl(std::shared_ptr instrList) { + double logProb(0.0); + const auto& instrVec = instrList->contents(); + for (const auto& instr : instrVec) { + logProb += ((*(declFunPtrs[instr->declID - 1 ])).*Method)(instr); + } return(logProb); } - + + void simulate_impl(std::shared_ptr instrList) { + const auto& instrVec = instrList->contents(); + for (const auto& instr : instrVec) { + declFunPtrs[instr->declID - 1 ]->simulate_cpp(instr); + } + } + // This version takes a character vector of names from R so that // the ordering of nodeFxns matches that in R, which is important for // the calculation instructions. + // This may become rarely used because we will generate into a derived + // model class a canonical ordering void do_setup_decl_mgmt_from_names(Rcpp::CharacterVector names) { - Rprintf("Attempting setup_decl_mgmt_from_names with %d names\n", (int)names.length()); + // Rprintf("Attempting setup_decl_mgmt_from_names with %d names\n", (int)names.length()); Derived *self = static_cast(this); const auto& name2access = self->get_name2access(); - nodeFxnPtrs.clear(); + declFunPtrs.clear(); name2index_map.clear(); size_t n = names.length(); for(size_t i = 0; i < n; ++i) { @@ -45,18 +63,18 @@ class modelClass_ : public modelBase_nClass { // So we can turn these messages into errors once things are working. bool got_one = (ptr != nullptr); if(got_one) { - Rprintf("HOORAY: field %s is genericInterfaceBaseC\n", name.c_str()); + // Rprintf("HOORAY: field %s is genericInterfaceBaseC\n", name.c_str()); std::shared_ptr ptr2 = std::dynamic_pointer_cast(ptr); bool step_two = (ptr2 != nullptr); if(step_two) { - Rprintf("AND IT IS A NODEFXN PTR!\n"); - name2index_map.emplace(name, nodeFxnPtrs.size()); - nodeFxnPtrs.push_back(ptr2); + // Rprintf("AND IT IS A NODEFXN PTR!\n"); + name2index_map.emplace(name, declFunPtrs.size()); + declFunPtrs.push_back(ptr2); } else { - Rprintf("but it is not a nodefxn ptr\n"); + // Rprintf("but it is not a nodefxn ptr\n"); } } else { - Rprintf("field %s is NOT a genericInterfaceBaseC\n", name.c_str()); + // Rprintf("field %s is NOT a genericInterfaceBaseC\n", name.c_str()); } } } @@ -65,33 +83,36 @@ class modelClass_ : public modelBase_nClass { // This version scans all members to find nodeFxns. // The resulting ordering comes from the order of the name2access map, // and so may not match R. This was written first but may fall out of common use. - void setup_decl_mgmt() { + // This may become rarely used because we will generate into a derived + // model class a canonical ordering + void setup_auto_decl_mgmt() { Derived *self = static_cast(this); const auto& name2access = self->get_name2access(); size_t n = name2access.size(); - Rprintf("There are %d member variables indexed:\n", (int)n); + //Rprintf("There are %d member variables indexed:\n", (int)n); auto i_n2a = name2access.begin(); auto end_n2a = name2access.end(); - nodeFxnPtrs.clear(); + declFunPtrs.clear(); name2index_map.clear(); size_t index = 0; for(; i_n2a != end_n2a; ++i_n2a) { std::shared_ptr ptr = i_n2a->second->getInterfacePtr(dynamic_cast(self)); bool got_one = (ptr != nullptr); if(got_one) { - Rprintf("HOORAY: field %s is genericInterfaceBaseC\n", i_n2a->first.c_str()); + // Rprintf("HOORAY: field %s is genericInterfaceBaseC\n", i_n2a->first.c_str()); std::shared_ptr ptr2 = std::dynamic_pointer_cast(ptr); bool step_two = (ptr2 != nullptr); if(step_two) { - Rprintf("AND IT IS A NODEFXN PTR!\n"); - nodeFxnPtrs.push_back(ptr2); + // Rprintf("AND IT IS A NODEFXN PTR!\n"); + declFunPtrs.push_back(ptr2); name2index_map.emplace(i_n2a->first, index++); } else { - Rprintf("but it is not a nodefxn ptr\n"); + // Rprintf("but it is not a nodefxn ptr\n"); } } - else - Rprintf("field %s is NOT a genericInterfaceBaseC\n", i_n2a->first.c_str()); + else { + // Rprintf("field %s is NOT a genericInterfaceBaseC\n", i_n2a->first.c_str()); + } } } void c_print_nodes() { diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 457b262..4a89c34 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -9,26 +9,105 @@ library(testthat) ## # To update the set of predefined nClasses ## # generate new predef/instr_nC. Move that directly to package code inst/nimbleModel/predef/instr_nC -nCompile(instr_nClass = nimbleModel:::instr_nClass, control=list(generate_predefined=TRUE)) -test <- nCompile(instr_nClass = nimbleModel:::instr_nClass) +## nCompile(instr_nClass = nimbleModel:::instr_nClass, control=list(generate_predefined=TRUE)) +## test <- nCompile(instr_nClass = nimbleModel:::instr_nClass) ## # ## # generate new predef/declFunBase_nC. Move to package and add ## # "#include " in the hContent ## # And add "// [[Rcpp::depends(nimbleModel)]]" to the cppContent ## # after declaration of declFunBase_nClass -nCompile(nimbleModel:::declFunBase_nClass, control=list(generate_predefined=TRUE)) -test <- nCompile(nimbleModel:::declFunBase_nClass) +## nCompile(nimbleModel:::declFunBase_nClass, control=list(generate_predefined=TRUE)) +## test <- nCompile(nimbleModel:::declFunBase_nClass) ## # ## # generate new predef/modelBase_nC. Move to package and add ## # "#include " to the hContent ## # And add "// [[Rcpp::depends(nimbleModel)]]" to the cppContent ## # after the declaration of modelBase_nClass. -nCompile(modelBase_nClass = nimbleModel:::modelBase_nClass, control=list(generate_predefined=TRUE)) -test <- nCompile(nimbleModel:::modelBase_nClass) +## nCompile(modelBase_nClass = nimbleModel:::modelBase_nClass, control=list(generate_predefined=TRUE)) +## test <- nCompile(nimbleModel:::modelBase_nClass) ## #nCompile(instr_nClass, modelBase_nClass, declFunBase_nClass, control=list(generate_predefined=TRUE)) ## TODO: revise these tests for instrClass (flattened approach) +test_that("initial test of compiled model", { + code <- quote({ + tau ~ dunif(0, 100) + mu ~ dnorm(0,1) + for(i in 1:5) { + y[i] ~ dnorm(mu, var = tau) + } + }) + + inits <- list(tau = 25, mu = 0) + data <- list(y = rnorm(5)) + + ## "Manual" workflow not using `nimbleModel()`. + nm <- modelClass$new(code, inits = inits, data = data) + mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) + + Cmclass <- nCompile(mclass) + Cobj <- Cmclass$new() + obj <- mclass$new() + + # Check a first calculation on a simple node + Cans <- Cobj$calculate('tau') + ans <- obj$calculate('tau') + check <- dunif(Cobj$tau, 0, 100, log = TRUE) + expect_equal(Cans, ans) + expect_equal(Cans, check) + + # Check entire model, also getting lifted sd node computed + Cans <- Cobj$calculate() + ans <- obj$calculate() + expect_equal(Cans, ans) + + # Check a sequence + Cans <- Cobj$calculate('y[1:3]') + ans <- obj$calculate('y[1:3]') + check <- dnorm(Cobj$y[1:3], Cobj$mu, sqrt(Cobj$tau), log=TRUE) |> sum() + expect_equal(Cans, ans) + expect_equal(Cans, check) + + # Check a non-contiguous pair of nodes (a mat case) + nodes <- c('y[2]','y[4]') + Cans <- Cobj$calculate(nodes) + ans <- obj$calculate(nodes) + check <- dnorm(Cobj$y[c(2, 4)], Cobj$mu, sqrt(Cobj$tau), log=TRUE) |> sum() + expect_equal(Cans, ans) + expect_equal(Cans, check) + + # Check getLogProb + Cans <- Cobj$getLogProb('y[1:4]') + ans <- obj$calculate('y[1:4]') + check <- dnorm(Cobj$y[1:4], Cobj$mu, sqrt(Cobj$tau), log=TRUE) |> sum() + expect_equal(Cans, ans) + expect_equal(Cans, check) + + # Prepare for calculateDiff test below + old_logProb <- dnorm(Cobj$y[3:4], Cobj$mu, sqrt(Cobj$tau), log=TRUE) |> sum() + + # Check simulate + set.seed(1) + Cobj$simulate('y[3:4]') + set.seed(1) + obj$simulate('y[3:4]') + expect_equal(Cobj$y, obj$y) + + # Check getLogProb + # Do this assignment in case the previous test of repeatability fails + obj$y[3:4] <- Cobj$y[3:4] + Cans <- Cobj$calculateDiff('y[3:4]') + ans <- obj$calculateDiff('y[3:4]') + new_logProb <- dnorm(Cobj$y[3:4], Cobj$mu, sqrt(Cobj$tau), log=TRUE) |> sum() + check <- new_logProb - old_logProb + expect_equal(Cans, ans) + expect_equal(Cans, check) + + # Always end compiled tests with removing and garbage collecting + # to ensure gc() happens while the DLL is still in place. + rm(Cobj, obj); gc() +}) + test_that("initial tests/examples of nimble model using flattened approach", { code <- quote({ @@ -44,15 +123,32 @@ test_that("initial tests/examples of nimble model using flattened approach", { ## "Manual" workflow not using `nimbleModel()`. nm <- modelClass$new(code, inits = inits, data = data) + #debug(nimbleModel:::make_modelClass_from_nimbleModel) + #debug(nimbleModel:::makeModel_nClass) mclass <- nimbleModel:::make_modelClass_from_nimbleModel(nm) # Begin Perry Cmclass <- nCompile(mclass) Cobj <- Cmclass$new() - Cobj$calculate_impl - Cobj$calculate - debug(Cobj$calculate) + #Cobj$calculate_impl + #Cobj$calculate + #debug(Cobj$calculate) Cobj$calculate('tau') + Cobj$calculate() + Cobj$calculate('y[1]') + dnorm(Cobj$y[1], Cobj$mu, sqrt(Cobj$tau), log=TRUE) + Cobj$calculate('y[1:3]') + dnorm(Cobj$y[1:3], Cobj$mu, sqrt(Cobj$tau), log=TRUE) |> sum() + + + NULL + + obj <- mclass$new() + obj$calculate() + #debug(obj$calculate) + obj$calculate('y[1]') + obj$calculate('y[1:3]') + NULL # PROBLEM, in nList_<>::set_from_list for uncompiled list input. # I guess set_all_values should skip NULLs? Or maybe only for non-R targets? # Give a better message than "Bad type". Pass the name? Check for NULL? From 4253b93473ebd11165f11ad12a55f1150056cffa Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Tue, 2 Jun 2026 07:56:55 -0700 Subject: [PATCH 25/32] Change where index offset is handled in calc seq case. --- nimbleModel/R/declFunBaseClass.R | 2 +- nimbleModel/R/instructions.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/nimbleModel/R/declFunBaseClass.R b/nimbleModel/R/declFunBaseClass.R index 33ae37b..8117d43 100644 --- a/nimbleModel/R/declFunBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -24,7 +24,7 @@ declFunBase_nClass <- nClass( calc_1_seq = function(instr, fn) { logProb = 0 - iStart <- instr$values[[1]][1] # Values seem to start offset by -1, a bit confusing + iStart <- instr$values[[1]][1]-1 for(i in 1:instr$lens[1]) logProb <- logProb + self[[fn]](iStart + i) return(logProb) diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index 4b49eab..c99af67 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -36,7 +36,7 @@ range2instr <- function(range) { instr$values <- lapply(range$indexingRange$indexRanges, function(x) switch(class(x)[1], "indexRangeScalarClass" = x$value, - "indexRangeSequenceClass" = x$start-1, # -1 to avoid constantly adding 1 in calculate() + "indexRangeSequenceClass" = x$start, "indexRangeMatrixClass" = c(t(matrix(x$values, nc = x$numColumns))))) # in calcRange, column major; need row major here for simpler/more efficient determination of indices } instr$type <- determineInstrType(instr) From 7a7c35586632fc4a901704b8d37a942dc3b684da Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Tue, 2 Jun 2026 08:29:42 -0700 Subject: [PATCH 26/32] Fix offset in C++ too; add calc test. --- .../predef/declFunClass_/declFunClass_.h | 2 +- nimbleModel/tests/testthat/test-nimbleModel.R | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h index 627cf9b..80335cf 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h @@ -34,7 +34,7 @@ class declFunClass_ : public declFunBase_nClass { double calc_1_seq_(std::shared_ptr instr) { int len = instr->lens[0]; if(len < 1) return(0); - int iStart = instr->values->operator[](0)[0] + 1; + int iStart = instr->values->operator[](0)[0]; int iEnd = iStart + len; Eigen::Tensor idx(1); double logProb(0.); diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 4a89c34..2be2b6c 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -259,6 +259,24 @@ test_that("initial tests/examples of nimble model using flattened approach", { }) +test_that("multiple index slot, single indexRange case", { + code <- quote({ + for(i in 1:5) + for(j in 1:3) + y[i,j] ~ dnorm(0,1) + }) + data <- list(y = matrix(rnorm(15),5)) + mclass <- nimbleModel(code, data = data) + m <- mclass$new() + vr <- varRangeClass$new(list(newIndexRange(matrix(c(2,4,3,1), ncol=2))), varName='y') + expect_equal(m$calculate(vr), dnorm(data$y[2,3],log=TRUE) + dnorm(data$y[4,1],log=TRUE)) + cmclass <- nCompile(mclass) + cm <- cmclass$new() + ## TODO: this is giving back 0. + expect_equal(cm$calculate(vr), dnorm(data$y[2,3],log=TRUE) + dnorm(data$y[4,1],log=TRUE)) + +}) + test_that("basic creation of list of instr_nClass objects", { code <- quote({ From 42220210a78038c1a93ba7f7fa8208ee93cce8cb Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Tue, 2 Jun 2026 09:09:20 -0700 Subject: [PATCH 27/32] Add calc_1_matp. --- .../predef/declFunClass_/declFunClass_.h | 37 +++++++++++++++++-- nimbleModel/tests/testthat/test-nimbleModel.R | 9 ++++- 2 files changed, 41 insertions(+), 5 deletions(-) diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h index 80335cf..5dcad92 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h @@ -24,6 +24,7 @@ class declFunClass_ : public declFunBase_nClass { if(instr_type == 0) return calc_0_< Method >(instr); if(instr_type == 1) return calc_1_seq_< Method >(instr); if(instr_type == 2) return calc_1_mat_< Method >(instr); + if(instr_type == 3) return calc_1_matp_< Method >(instr); return(0); } template @@ -53,18 +54,35 @@ class declFunClass_ : public declFunBase_nClass { Eigen::Tensor idx(1); double logProb(0.); for(int i = 0; i < len; ++i) { - idx[0] = vals[i]; + idx[0] = vals[i]; // TODO: do we need this additional assignment? logProb += (static_cast(this)->*Method)(idx); } return(logProb); } - // simulate + template + double calc_1_matp_(std::shared_ptr instr) { + int len = instr->lens[0]; + int dm = instr->dims[0]; + const auto& vals = instr->values->operator[](0); + if(len*dm != vals.size()) std::cout<<"len*dm != vals.size() in calc_1_matp_"< idx(dm); + double logProb(0.); + for(int i = 0; i < len; ++i) { + for(int p = 0; p < dm; ++p) + idx[p] = vals[i*dm+p]; + logProb += (static_cast(this)->*Method)(idx); // TODO: can we just pass vals, starting_point + } + return(logProb); + } + // simulate void simulate_cpp ( std::shared_ptr instr ) { RESET_EIGEN_ERRORS; int instr_type = instr->type; if(instr_type == 0) return sim_0_(instr); if(instr_type == 1) return sim_1_seq_(instr); if(instr_type == 2) return sim_1_mat_(instr); + if(instr_type == 3) return sim_1_matp_(instr); } void sim_0_ (std::shared_ptr instr) { static_cast(this)->sim_one(instr->lens); // lens serves as a dummy here, to have the right type to pass @@ -91,8 +109,19 @@ class declFunClass_ : public declFunBase_nClass { static_cast(this)->sim_one(idx); } } - - + void sim_1_matp_(std::shared_ptr instr) { + int len = instr->lens[0]; + int dm = instr->dims[0]; + const auto& vals = instr->values->operator[](0); + if(len*dm != vals.size()) std::cout<<"len*dm != vals.size() in sim_1_matp_"< idx(dm); + for(int i = 0; i < len; ++i) { + for(int p = 0; p < dm; ++p) + idx[p] = vals[i*dm+p]; + static_cast(this)->sim_one(idx); + } + } virtual ~declFunClass_() {}; }; diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 2be2b6c..45716d9 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -259,7 +259,8 @@ test_that("initial tests/examples of nimble model using flattened approach", { }) -test_that("multiple index slot, single indexRange case", { +test_that("multiple index slots, single indexRange case", { + library(nimbleModel); library(nCompiler); library(testthat) code <- quote({ for(i in 1:5) for(j in 1:3) @@ -275,6 +276,12 @@ test_that("multiple index slot, single indexRange case", { ## TODO: this is giving back 0. expect_equal(cm$calculate(vr), dnorm(data$y[2,3],log=TRUE) + dnorm(data$y[4,1],log=TRUE)) + set.seed(1) + m$simulate(vr) + set.seed(1) + cm$simulate(vr) + expect_equal(m$y, cm$y) + }) test_that("basic creation of list of instr_nClass objects", { From aac4a5768d4b3cc50da0be13911789157ca8899c Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Tue, 2 Jun 2026 17:34:29 -0700 Subject: [PATCH 28/32] Add calc_2_seq_seq and related decl funs. --- nimbleModel/R/declFunBaseClass.R | 54 ++++++++++++++----- nimbleModel/R/instructions.R | 2 +- .../predef/declFunClass_/declFunClass_.h | 45 +++++++++++++++- nimbleModel/tests/testthat/test-nimbleModel.R | 26 ++++++++- 4 files changed, 110 insertions(+), 17 deletions(-) diff --git a/nimbleModel/R/declFunBaseClass.R b/nimbleModel/R/declFunBaseClass.R index 8117d43..e5787da 100644 --- a/nimbleModel/R/declFunBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -16,6 +16,7 @@ declFunBase_nClass <- nClass( if(instr$type == 1) return(calc_1_seq(instr, fn)) if(instr$type == 2) return(calc_1_mat(instr, fn)) if(instr$type == 3) return(calc_1_matp(instr, fn)) + if(instr$type == 4) return(calc_2_seq_seq(instr, fn)) return(0) }, calc_0 = function(instr, fn) { @@ -40,30 +41,59 @@ declFunBase_nClass <- nClass( function(instr, fn) { logProb = 0 for(i in 1:instr$lens[1]) - logProb <- logProb + self[[fn]](instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? + logProb <- logProb + self[[fn]](instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) return(logProb) }, - simulate = function(instr) { + calc_2_seq_seq = + function(instr, fn) { + logProb <- 0 + idx <- rep(0, 2) + iStart1 <- instr$values[[1]][1]-1 + for(i in 1:instr$lens[1]) { + idx[1] <- iStart1 + i + iStart2 <- instr$values[[2]][1]-1 + for(j in 1:instr$lens[2]) { + idx[2] <- iStart2 + j + logProb <- logProb + self[[fn]](idx) + } + } + return(logProb) + }, + simulate = function(instr) { if(instr$type == 0) return(sim_0(instr)) if(instr$type == 1) return(sim_1_seq(instr)) if(instr$type == 2) return(sim_1_mat(instr)) if(instr$type == 3) return(sim_1_matp(instr)) + if(instr$type == 4) return(sim_2_seq_seq(instr)) }, - sim_0 = function(instr) { - sim_one(0) ## sim_one will always has `idx` as arg? + sim_0 = function(instr) { + sim_one(0) }, - sim_1_seq = function(instr) { + sim_1_seq = function(instr) { for(i in 1:instr$lens[1]) - sim_one(instr$values[[1]][1]+i) + sim_one(instr$values[[1]][1]+i) }, - sim_1_mat = function(instr) { + sim_1_mat = function(instr) { for(i in 1:instr$lens[1]) - sim_one(instr$values[[1]][i]) - }, - sim_1_matp = function(instr) { + sim_one(instr$values[[1]][i]) + }, + sim_1_matp = function(instr) { for(i in 1:instr$lens[1]) - sim_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) ## Ok to call with a vector? - } + sim_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) + }, + sim_2_seq_seq = + function(instr, fn) { + idx <- rep(0, 2) + iStart1 <- instr$values[[1]][1]-1 + for(i in 1:instr$lens[1]) { + idx[1] <- iStart1 + i + iStart2 <- instr$values[[2]][1]-1 + for(j in 1:instr$lens[2]) { + idx[2] <- iStart2 + j + sim_one(idx) + } + } + } ), Cpublic = list( ## model = 'modelBase_nClass', diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index c99af67..13db486 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -63,7 +63,7 @@ determineInstrType <- function(instr, use_vec = FALSE) { if(identical(instr$dims, c(1L,1L))) { ## Some of these not yet written. if(identical(instr$index_types, c(1,1))) - type <- "2_vec_vec" + type <- "2_seq_seq" if(identical(instr$index_types, c(1,2))) if(instr$dims[2] == 1) type <- "2_seq_mat" else type <- "2_seq_matp" if(identical(instr$index_types, c(2,1))) diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h index 5dcad92..f873922 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h @@ -25,6 +25,7 @@ class declFunClass_ : public declFunBase_nClass { if(instr_type == 1) return calc_1_seq_< Method >(instr); if(instr_type == 2) return calc_1_mat_< Method >(instr); if(instr_type == 3) return calc_1_matp_< Method >(instr); + if(instr_type == 4) return calc_2_seq_seq_< Method >(instr); return(0); } template @@ -54,7 +55,7 @@ class declFunClass_ : public declFunBase_nClass { Eigen::Tensor idx(1); double logProb(0.); for(int i = 0; i < len; ++i) { - idx[0] = vals[i]; // TODO: do we need this additional assignment? + idx[0] = vals[i]; logProb += (static_cast(this)->*Method)(idx); } return(logProb); @@ -75,6 +76,28 @@ class declFunClass_ : public declFunBase_nClass { } return(logProb); } + template + double calc_2_seq_seq_(std::shared_ptr instr) { + int len1 = instr->lens[0]; + int len2 = instr->lens[1]; + if(len1 < 1) return(0); + if(len2 < 1) return(0); + int iStart1 = instr->values->operator[](0)[0]; + int iEnd1 = iStart1 + len1; + int iStart2 = instr->values->operator[](1)[0]; + int iEnd2 = iStart2 + len2; + Eigen::Tensor idx(2); + double logProb(0.); + for(int i = iStart1; i < iEnd1; ++i) { + idx[0] = i; + for(int j = iStart2; j < iEnd2; ++j) { + idx[1] = j; + logProb += (static_cast(this)->*Method)(idx); + } + } + return(logProb); + + } // simulate void simulate_cpp ( std::shared_ptr instr ) { RESET_EIGEN_ERRORS; @@ -83,6 +106,7 @@ class declFunClass_ : public declFunBase_nClass { if(instr_type == 1) return sim_1_seq_(instr); if(instr_type == 2) return sim_1_mat_(instr); if(instr_type == 3) return sim_1_matp_(instr); + if(instr_type == 4) return sim_2_seq_seq_(instr); } void sim_0_ (std::shared_ptr instr) { static_cast(this)->sim_one(instr->lens); // lens serves as a dummy here, to have the right type to pass @@ -122,6 +146,23 @@ class declFunClass_ : public declFunBase_nClass { static_cast(this)->sim_one(idx); } } - + void sim_2_seq_seq_(std::shared_ptr instr) { + int len1 = instr->lens[0]; + int len2 = instr->lens[1]; + if(len1 < 1) return; + if(len2 < 1) return; + int iStart1 = instr->values->operator[](0)[0]; + int iEnd1 = iStart1 + len1; + int iStart2 = instr->values->operator[](1)[0]; + int iEnd2 = iStart2 + len2; + Eigen::Tensor idx(2); + for(int i = iStart1; i < iEnd1; ++i) { + idx[0] = i; + for(int j = iStart2; j < iEnd2; ++j) { + idx[1] = j; + static_cast(this)->sim_one(idx); + } + } + } virtual ~declFunClass_() {}; }; diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 45716d9..a7a416f 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -260,7 +260,6 @@ test_that("initial tests/examples of nimble model using flattened approach", { }) test_that("multiple index slots, single indexRange case", { - library(nimbleModel); library(nCompiler); library(testthat) code <- quote({ for(i in 1:5) for(j in 1:3) @@ -273,7 +272,6 @@ test_that("multiple index slots, single indexRange case", { expect_equal(m$calculate(vr), dnorm(data$y[2,3],log=TRUE) + dnorm(data$y[4,1],log=TRUE)) cmclass <- nCompile(mclass) cm <- cmclass$new() - ## TODO: this is giving back 0. expect_equal(cm$calculate(vr), dnorm(data$y[2,3],log=TRUE) + dnorm(data$y[4,1],log=TRUE)) set.seed(1) @@ -284,6 +282,30 @@ test_that("multiple index slots, single indexRange case", { }) +test_that("two sequences case", { + library(nCompiler); library(nimbleModel); library(testthat) + code <- quote({ + for(i in 1:5) + for(j in 1:3) + y[i,j] ~ dnorm(0,1) + }) + data <- list(y = matrix(rnorm(15),5)) + mclass <- nimbleModel(code, data = data) + truth <- sum(dnorm(data$y[2:4,1:3],0,1,log=TRUE)) + m <- mclass$new() + expect_equal(m$calculate('y[2:4,1:3]'), truth) + cmclass <- nCompile(mclass) + cm <- cmclass$new() + expect_equal(cm$calculate('y[2:4,1:3]'), truth) + + set.seed(1) + m$simulate('y[2:4,1:3]') + set.seed(1) + cm$simulate('y[2:4,1:3]') + expect_equal(m$y, cm$y) + +}) + test_that("basic creation of list of instr_nClass objects", { code <- quote({ From a89c6a4d8e265cd0eb4fb124ff0250c78badf5c4 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 3 Jun 2026 08:32:13 -0700 Subject: [PATCH 29/32] Add initial calc cases with slot reordering. --- nimbleModel/R/declFunBaseClass.R | 54 ++++++++++- nimbleModel/R/instructions.R | 28 +++--- .../predef/declFunClass_/declFunClass_.h | 90 +++++++++++++++++-- nimbleModel/tests/testthat/test-nimbleModel.R | 43 ++++++++- 4 files changed, 195 insertions(+), 20 deletions(-) diff --git a/nimbleModel/R/declFunBaseClass.R b/nimbleModel/R/declFunBaseClass.R index e5787da..adae7a6 100644 --- a/nimbleModel/R/declFunBaseClass.R +++ b/nimbleModel/R/declFunBaseClass.R @@ -16,7 +16,9 @@ declFunBase_nClass <- nClass( if(instr$type == 1) return(calc_1_seq(instr, fn)) if(instr$type == 2) return(calc_1_mat(instr, fn)) if(instr$type == 3) return(calc_1_matp(instr, fn)) - if(instr$type == 4) return(calc_2_seq_seq(instr, fn)) + if(instr$type == 4) return(calc_1_matp_ord(instr, fn)) + if(instr$type == 5) return(calc_2_seq_seq(instr, fn)) + if(instr$type == 6) return(calc_2_seq_seq_ord(instr, fn)) return(0) }, calc_0 = function(instr, fn) { @@ -44,6 +46,13 @@ declFunBase_nClass <- nClass( logProb <- logProb + self[[fn]](instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) return(logProb) }, + calc_1_matp_ord = + function(instr, fn) { + logProb = 0 + for(i in 1:instr$lens[1]) + logProb <- logProb + self[[fn]](instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)][instr$slots]) + return(logProb) + }, calc_2_seq_seq = function(instr, fn) { logProb <- 0 @@ -59,12 +68,31 @@ declFunBase_nClass <- nClass( } return(logProb) }, + calc_2_seq_seq_ord = + function(instr, fn) { + if(!identical(instr$slots, 1:2)) + stop("Slots not equal to 2,1 in calc_2_seq_seq_ord") + logProb <- 0 + idx <- rep(0, 2) + iStart1 <- instr$values[[1]][1]-1 + for(i in 1:instr$lens[1]) { + idx[2] <- iStart1 + i + iStart2 <- instr$values[[2]][1]-1 + for(j in 1:instr$lens[2]) { + idx[1] <- iStart2 + j + logProb <- logProb + self[[fn]](idx) + } + } + return(logProb) + }, simulate = function(instr) { if(instr$type == 0) return(sim_0(instr)) if(instr$type == 1) return(sim_1_seq(instr)) if(instr$type == 2) return(sim_1_mat(instr)) if(instr$type == 3) return(sim_1_matp(instr)) - if(instr$type == 4) return(sim_2_seq_seq(instr)) + if(instr$type == 4) return(sim_1_matp_ord(instr)) + if(instr$type == 5) return(sim_2_seq_seq(instr)) + if(instr$type == 6) return(sim_2_seq_seq_ord(instr)) }, sim_0 = function(instr) { sim_one(0) @@ -81,6 +109,10 @@ declFunBase_nClass <- nClass( for(i in 1:instr$lens[1]) sim_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)]) }, + sim_1_matp_ord = function(instr) { + for(i in 1:instr$lens[1]) + sim_one(instr$values[[1]][(instr$dims[1]*(i-1) + 1):(instr$dims[1]*i)][instr$slots]) + }, sim_2_seq_seq = function(instr, fn) { idx <- rep(0, 2) @@ -93,8 +125,26 @@ declFunBase_nClass <- nClass( sim_one(idx) } } + }, + sim_2_seq_seq_ord = + function(instr, fn) { + if(!identical(instr$slots, 1:2)) + stop("Slots not equal to 2,1 in calc_2_seq_seq_ord") + idx <- rep(0, 2) + iStart1 <- instr$values[[1]][1]-1 + for(i in 1:instr$lens[1]) { + idx[2] <- iStart1 + i + iStart2 <- instr$values[[2]][1]-1 + for(j in 1:instr$lens[2]) { + idx[1] <- iStart2 + j + sim_one(idx) + } + } } + + ), + Cpublic = list( ## model = 'modelBase_nClass', ping = nFunction( diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index 13db486..698a3bf 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -3,16 +3,18 @@ type2itype <- list( "1_seq" = 1, "1_mat" = 2, "1_matp" = 3, - "2_seq_seq" = 4, - "2_seq_mat" = 5, - "2_mat_seq" = 6, - "2_mat_mat" = 7, - "2_seq_matp" = 8, - "2_matp_seq" = 9, - "2_matp_matp" = 10, - "2_mat_matp" = 11, - "2_matp_mat" = 12, - "3_generic" = 13 # Need to deal with itype for _slot cases. + "1_matp_ord" = 4, + "2_seq_seq" = 5, + "2_seq_seq_ord" = 6, + "2_seq_mat" = 7, + "2_mat_seq" = 8, + "2_mat_mat" = 9, + "2_seq_matp" = 10, + "2_matp_seq" = 11, + "2_matp_matp" = 12, + "2_mat_matp" = 13, + "2_matp_mat" = 14, + "3_generic" = 15 # Need to deal with itype for _slot cases. ) ## Stand-alone function for setting up inputs to instrClass constructor. @@ -57,13 +59,15 @@ determineInstrType <- function(instr, use_vec = FALSE) { if(instr$index_types[1] == 1) { type <- "1_seq" } else { - if(instr$dims[1] == 1) type <- "1_mat" else type <- "1_matp" + if(instr$dims[1] == 1) type <- "1_mat" else { + if(identical(instr$slots, 1:length(instr$slots))) type <- "1_matp" else type <- "1_matp_ord" + } } if(length(instr$dims) == 2) if(identical(instr$dims, c(1L,1L))) { ## Some of these not yet written. if(identical(instr$index_types, c(1,1))) - type <- "2_seq_seq" + if(identical(instr$slots, 1:2)) type <- "2_seq_seq" else type <- "2_seq_seq_ord" if(identical(instr$index_types, c(1,2))) if(instr$dims[2] == 1) type <- "2_seq_mat" else type <- "2_seq_matp" if(identical(instr$index_types, c(2,1))) diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h index f873922..1327308 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h @@ -25,7 +25,9 @@ class declFunClass_ : public declFunBase_nClass { if(instr_type == 1) return calc_1_seq_< Method >(instr); if(instr_type == 2) return calc_1_mat_< Method >(instr); if(instr_type == 3) return calc_1_matp_< Method >(instr); - if(instr_type == 4) return calc_2_seq_seq_< Method >(instr); + if(instr_type == 4) return calc_1_matp_ord_< Method >(instr); + if(instr_type == 5) return calc_2_seq_seq_< Method >(instr); + if(instr_type == 6) return calc_2_seq_seq_ord_< Method >(instr); return(0); } template @@ -72,7 +74,26 @@ class declFunClass_ : public declFunBase_nClass { for(int i = 0; i < len; ++i) { for(int p = 0; p < dm; ++p) idx[p] = vals[i*dm+p]; - logProb += (static_cast(this)->*Method)(idx); // TODO: can we just pass vals, starting_point + logProb += (static_cast(this)->*Method)(idx); + } + return(logProb); + } + template + double calc_1_matp_ord_(std::shared_ptr instr) { + int len = instr->lens[0]; + int dm = instr->dims[0]; + const auto& vals = instr->values->operator[](0); + if(len*dm != vals.size()) std::cout<<"len*dm != vals.size() in calc_1_matp_"< idx(dm); + Eigen::Tensor slots(dm); + for(int p = 0; p < dm; ++p) + slots[p] = instr->slots[p]-1; + double logProb(0.); + for(int i = 0; i < len; ++i) { + for(int p = 0; p < dm; ++p) + idx[slots[p]] = vals[i*dm+p]; + logProb += (static_cast(this)->*Method)(idx); } return(logProb); } @@ -96,9 +117,30 @@ class declFunClass_ : public declFunBase_nClass { } } return(logProb); - + template + double calc_2_seq_seq_ord_(std::shared_ptr instr) { + if(instr->slots[0] != 2 || instr->slots[1] != 1) + std::cout<<"slots not equal to 2,1 in calc_2_seq_seq_ord_"<lens[0]; + int len2 = instr->lens[1]; + if(len1 < 1) return(0); + if(len2 < 1) return(0); + int iStart1 = instr->values->operator[](0)[0]; + int iEnd1 = iStart1 + len1; + int iStart2 = instr->values->operator[](1)[0]; + int iEnd2 = iStart2 + len2; + Eigen::Tensor idx(2); + double logProb(0.); + for(int i = iStart1; i < iEnd1; ++i) { + idx[1] = i; + for(int j = iStart2; j < iEnd2; ++j) { + idx[0] = j; + logProb += (static_cast(this)->*Method)(idx); + } + } + return(logProb); } - // simulate + // simulate void simulate_cpp ( std::shared_ptr instr ) { RESET_EIGEN_ERRORS; int instr_type = instr->type; @@ -106,7 +148,9 @@ class declFunClass_ : public declFunBase_nClass { if(instr_type == 1) return sim_1_seq_(instr); if(instr_type == 2) return sim_1_mat_(instr); if(instr_type == 3) return sim_1_matp_(instr); - if(instr_type == 4) return sim_2_seq_seq_(instr); + if(instr_type == 4) return sim_1_matp_ord_(instr); + if(instr_type == 5) return sim_2_seq_seq_(instr); + if(instr_type == 6) return sim_2_seq_seq_ord_(instr); } void sim_0_ (std::shared_ptr instr) { static_cast(this)->sim_one(instr->lens); // lens serves as a dummy here, to have the right type to pass @@ -146,6 +190,22 @@ class declFunClass_ : public declFunBase_nClass { static_cast(this)->sim_one(idx); } } + void sim_1_matp_ord_(std::shared_ptr instr) { + int len = instr->lens[0]; + int dm = instr->dims[0]; + const auto& vals = instr->values->operator[](0); + if(len*dm != vals.size()) std::cout<<"len*dm != vals.size() in sim_1_matp_"< idx(dm); + Eigen::Tensor slots(dm); + for(int p = 0; p < dm; ++p) + slots[p] = instr->slots[p]-1; + for(int i = 0; i < len; ++i) { + for(int p = 0; p < dm; ++p) + idx[slots[p]] = vals[i*dm+p]; + static_cast(this)->sim_one(idx); + } + } void sim_2_seq_seq_(std::shared_ptr instr) { int len1 = instr->lens[0]; int len2 = instr->lens[1]; @@ -164,5 +224,25 @@ class declFunClass_ : public declFunBase_nClass { } } } + void sim_2_seq_seq_ord_(std::shared_ptr instr) { + if(instr->slots[0] != 2 || instr->slots[1] != 1) + std::cout<<"slots not equal to 2,1 in calc_2_seq_seq_ord_"<lens[0]; + int len2 = instr->lens[1]; + if(len1 < 1) return; + if(len2 < 1) return; + int iStart1 = instr->values->operator[](0)[0]; + int iEnd1 = iStart1 + len1; + int iStart2 = instr->values->operator[](1)[0]; + int iEnd2 = iStart2 + len2; + Eigen::Tensor idx(2); + for(int i = iStart1; i < iEnd1; ++i) { + idx[1] = i; + for(int j = iStart2; j < iEnd2; ++j) { + idx[0] = j; + static_cast(this)->sim_one(idx); + } + } + } virtual ~declFunClass_() {}; }; diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index a7a416f..425ae7c 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -279,11 +279,35 @@ test_that("multiple index slots, single indexRange case", { set.seed(1) cm$simulate(vr) expect_equal(m$y, cm$y) + + ## Now with slot reordering. + vr <- varRangeClass$new(list(newIndexRange(matrix(c(2,4,3,1), ncol=2))), + rangeToIndex = list(2:1), varName='y') + expect_equal(m$calculate(vr), dnorm(data$y[3,2],log=TRUE) + dnorm(data$y[1,4],log=TRUE)) + expect_equal(cm$calculate(vr), dnorm(data$y[3,2],log=TRUE) + dnorm(data$y[1,4],log=TRUE)) + + ## 3-d case for more robust ordering check + code <- quote({ + for(i in 1:5) + for(j in 1:4) + for(k in 1:3) + y[i,j,k] ~ dnorm(0,1) + }) + data <- list(y = array(rnorm(60),c(5,4,3))) + mclass <- nimbleModel(code, data = data) + m <- mclass$new() + vr <- varRangeClass$new(list(newIndexRange(matrix(c(2,3,1,3,5,2,1,2,4), ncol=3))), + rangeToIndex = list(c(3,1,2)), varName='y') + truth <- dnorm(data$y[3,1,2],log=TRUE) + dnorm(data$y[5,2,3],log=TRUE) + dnorm(data$y[2,4,1],log=TRUE) + expect_equal(m$calculate(vr), truth) + cmclass <- nCompile(mclass) + cm <- cmclass$new() + expect_equal(cm$calculate(vr), truth) + }) test_that("two sequences case", { - library(nCompiler); library(nimbleModel); library(testthat) code <- quote({ for(i in 1:5) for(j in 1:3) @@ -303,6 +327,23 @@ test_that("two sequences case", { set.seed(1) cm$simulate('y[2:4,1:3]') expect_equal(m$y, cm$y) + + ## 2-d case for ordering check. + code <- quote({ + for(i in 1:5) + for(j in 1:2) + y[i,j] ~ dnorm(0,1) + }) + data <- list(y = matrix(rnorm(20),5)) + mclass <- nimbleModel(code, data = data) + m <- mclass$new() + vr <- varRangeClass$new(list(newIndexRange(quote(1:2)), newIndexRange(quote(1:5))), + rangeToIndex = list(c(2,1)), varName='y') + truth <- sum(dnorm(data$y, log = TRUE)) + expect_equal(m$calculate(vr), truth) + cmclass <- nCompile(mclass) + cm <- cmclass$new() + expect_equal(cm$calculate(vr), truth) }) From b741c926d36a462427f3c5bb9cc34d1f0c7d844f Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 3 Jun 2026 08:32:46 -0700 Subject: [PATCH 30/32] Make slight edit to testing. --- nimbleModel/tests/testthat/test-nimbleModel.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 425ae7c..8ff456f 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -282,7 +282,7 @@ test_that("multiple index slots, single indexRange case", { ## Now with slot reordering. vr <- varRangeClass$new(list(newIndexRange(matrix(c(2,4,3,1), ncol=2))), - rangeToIndex = list(2:1), varName='y') + rangeToIndexSlot = list(2:1), varName='y') expect_equal(m$calculate(vr), dnorm(data$y[3,2],log=TRUE) + dnorm(data$y[1,4],log=TRUE)) expect_equal(cm$calculate(vr), dnorm(data$y[3,2],log=TRUE) + dnorm(data$y[1,4],log=TRUE)) @@ -297,7 +297,7 @@ test_that("multiple index slots, single indexRange case", { mclass <- nimbleModel(code, data = data) m <- mclass$new() vr <- varRangeClass$new(list(newIndexRange(matrix(c(2,3,1,3,5,2,1,2,4), ncol=3))), - rangeToIndex = list(c(3,1,2)), varName='y') + rangeToIndexSlot = list(c(3,1,2)), varName='y') truth <- dnorm(data$y[3,1,2],log=TRUE) + dnorm(data$y[5,2,3],log=TRUE) + dnorm(data$y[2,4,1],log=TRUE) expect_equal(m$calculate(vr), truth) cmclass <- nCompile(mclass) @@ -338,7 +338,7 @@ test_that("two sequences case", { mclass <- nimbleModel(code, data = data) m <- mclass$new() vr <- varRangeClass$new(list(newIndexRange(quote(1:2)), newIndexRange(quote(1:5))), - rangeToIndex = list(c(2,1)), varName='y') + rangeToIndexSlot = list(c(2,1)), varName='y') truth <- sum(dnorm(data$y, log = TRUE)) expect_equal(m$calculate(vr), truth) cmclass <- nCompile(mclass) From ee3e320ab0a3df7a4a75537851955347bac21c34 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 3 Jun 2026 09:17:23 -0700 Subject: [PATCH 31/32] Fix some tests; add full enum of calc types. --- nimbleModel/R/instructions.R | 36 ++++++++++++------- .../predef/declFunClass_/declFunClass_.h | 1 + nimbleModel/tests/testthat/test-nimbleModel.R | 6 ++-- 3 files changed, 29 insertions(+), 14 deletions(-) diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index 698a3bf..c6184f1 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -3,18 +3,30 @@ type2itype <- list( "1_seq" = 1, "1_mat" = 2, "1_matp" = 3, - "1_matp_ord" = 4, - "2_seq_seq" = 5, - "2_seq_seq_ord" = 6, - "2_seq_mat" = 7, - "2_mat_seq" = 8, - "2_mat_mat" = 9, - "2_seq_matp" = 10, - "2_matp_seq" = 11, - "2_matp_matp" = 12, - "2_mat_matp" = 13, - "2_matp_mat" = 14, - "3_generic" = 15 # Need to deal with itype for _slot cases. + "2_seq_seq" = 4, # done + "2_seq_mat" = 5, + "2_mat_seq" = 6, + "2_mat_mat" = 7, + "2_seq_matp" = 8, + "2_matp_seq" = 9, + "2_mat_matp" = 10, + "2_matp_mat" = 11, + "2_matp_matp" = 12, + "3_seq_seq_seq" = 13, + "3_generic" = 14, + "1_matp_ord" = 15, # done + ### Probably not needed given reordering when apply graph rules to create instrList. ### + "2_seq_seq_ord" = 16, # done + "2_seq_mat_ord" = 17, + "2_mat_seq_ord" = 18, + "2_mat_mat_ord" = 19, + ######################################################################################### + "2_seq_matp_ord" = 20, + "2_matp_seq_ord" = 21, + "2_mat_matp_ord" = 22, + "2_matp_mat_ord" = 23, + "2_matp_matp_ord" = 24, + "3_generic_ord" = 25 ) ## Stand-alone function for setting up inputs to instrClass constructor. diff --git a/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h index 1327308..72fa4f2 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunClass_/declFunClass_.h @@ -117,6 +117,7 @@ class declFunClass_ : public declFunBase_nClass { } } return(logProb); + } template double calc_2_seq_seq_ord_(std::shared_ptr instr) { if(instr->slots[0] != 2 || instr->slots[1] != 1) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 8ff456f..901abe8 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -329,16 +329,18 @@ test_that("two sequences case", { expect_equal(m$y, cm$y) ## 2-d case for ordering check. + ## This does not test calc_2_seq_seq_ord because rule application in creating instr + ## already re-sorts the indexRanges. code <- quote({ for(i in 1:5) for(j in 1:2) y[i,j] ~ dnorm(0,1) }) - data <- list(y = matrix(rnorm(20),5)) + data <- list(y = matrix(rnorm(10),5)) mclass <- nimbleModel(code, data = data) m <- mclass$new() vr <- varRangeClass$new(list(newIndexRange(quote(1:2)), newIndexRange(quote(1:5))), - rangeToIndexSlot = list(c(2,1)), varName='y') + rangeToIndexSlot = list(2,1), varName='y') truth <- sum(dnorm(data$y, log = TRUE)) expect_equal(m$calculate(vr), truth) cmclass <- nCompile(mclass) From 2dc7da9b926ff041a6c7d5e95316883b0d469929 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 3 Jun 2026 09:23:16 -0700 Subject: [PATCH 32/32] Rename dim to nDim in instrClass. --- nimbleModel/R/instructions.R | 12 ++++++------ .../predef/instr_nClass/instr_nClass_cppContent.cpp | 2 +- .../predef/instr_nClass/instr_nClass_hContent.h | 2 +- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index c6184f1..f614280 100644 --- a/nimbleModel/R/instructions.R +++ b/nimbleModel/R/instructions.R @@ -36,11 +36,11 @@ range2instr <- function(range) { if(!length(range$indexingRange$indexRanges)) { # No indexing instr$lens <- 1 instr$index_types <- 0 - instr$dim <- 0 + instr$nDim <- 0 } else { instr$lens <- sapply(range$indexingRange$indexRanges, function(x) x$numElements) instr$dims <- sapply(range$indexingRange$rangeToIndexSlot, length) - instr$dim <- sum(instr$dims) + instr$nDim <- sum(instr$dims) instr$slots <- unlist(range$indexingRange$rangeToIndexSlot) instr$index_types <- sapply(range$indexingRange$indexRanges, function(x) switch(class(x)[1], @@ -94,7 +94,7 @@ determineInstrType <- function(instr, use_vec = FALSE) { if(length(instr$dims) == 3) type <- "3_generic" if(is.null(type)) stop("no available specific instruction type") ## TODO: determine how much about slots will be pre-baked. - if(length(instr$dims) && !identical(instr$slots, 1:instr$dim)) # Non-canonical slot ordering + if(length(instr$dims) && !identical(instr$slots, 1:instr$nDim)) # Non-canonical slot ordering type <- paste(type, "slots", sep = "_") return(type2itype[[type]]) } @@ -151,12 +151,12 @@ instr_nClass <- nClass( instr <- range2instr(calcRange) # This processing could simply be included here in `initialize`. self$lens <- instr$lens %||% integer() self$index_types <- instr$index_types %||% integer() - self$dim <- instr$dim %||% 0L + self$nDim <- instr$nDim %||% 0L self$dims <- instr$dims %||% integer() self$slots <- instr$slots %||% integer() self$values <- nList(integerVector)$new() self$values$setLength(length(self$dims)) - if(self$dim) + if(self$nDim) for(i in 1:length(self$dims)) self$values[[i]] <- instr$values[[i]] self$type <- instr$type %||% 0L # Use integer for compilation (would char be ok?). @@ -167,7 +167,7 @@ instr_nClass <- nClass( Cpublic = list( lens = 'integerVector', index_types = 'integerVector', - dim = 'integerScalar', + nDim = 'integerScalar', dims = 'integerVector', slots = 'integerVector', values = 'nList(integerVector)', diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp index 66a0779..656aa1c 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp +++ b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp @@ -41,7 +41,7 @@ instr_nClass, NCOMPILER_FIELDS( field("lens", &instr_nClass::lens), field("index_types", &instr_nClass::index_types), -field("dim", &instr_nClass::dim), +field("nDim", &instr_nClass::nDim), field("dims", &instr_nClass::dims), field("slots", &instr_nClass::slots), field("values", &instr_nClass::values), diff --git a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h index 615ee99..f964e2c 100644 --- a/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h +++ b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_hContent.h @@ -13,7 +13,7 @@ class instr_nClass : public interface_resolver< genericInterfaceC instr_nClass ( ) ; Eigen::Tensor lens; Eigen::Tensor index_types; - int dim; + int nDim; Eigen::Tensor dims; Eigen::Tensor slots; std::shared_ptr values;