diff --git a/nimbleModel/.DS_Store b/nimbleModel/.DS_Store new file mode 100644 index 0000000..59c8ece Binary files /dev/null and b/nimbleModel/.DS_Store differ diff --git a/nimbleModel/R/declFunBaseClass.R b/nimbleModel/R/declFunBaseClass.R index cd46a58..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,183 +72,97 @@ 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' - ), - 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", - 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' - ) ), ## 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..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,14 +157,21 @@ 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", - 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..15d3ee9 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -7,18 +7,20 @@ 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_ 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,52 +88,45 @@ modelBase_nClass <- nClass( includePredictive, predictiveOnly, includeRHSonly, topOnly, latentOnly, endOnly) }, - calculate = function(input) { - if(missing(input)) - input <- getVarNames() - instrList <- makeInstrList(self,input) - if(isCompiled()) - return(calculate_impl(instrList)) + 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(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]]) - } + 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(input) { - if(missing(input)) - input <- getVarNames() - instrList <- makeInstrList(self, input) + simulate = function(instr) { + if(missing(instr)) + instr <- getVarNames() + instrList <- makeInstrList(self,instr) if(isCompiled()) { - simulate_impl(instrList) - } else + if(!instrList$isCompiled()) instrList <- makeCompiledInstrList(instrList) + self$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) + return(invisible(NULL)) } ), Cpublic = list( @@ -143,6 +138,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) { @@ -153,11 +157,11 @@ modelBase_nClass <- nClass( compileInfo = list( C_fun = function(instrList = 'nList(instr_nClass)') { ## NOTE: instrList input will be ordered. - cppLiteral('modelClass_::calculate(instrList);') + cppLiteral('Rprintf("modelBase_nClass calculate_impl (should not see this)\\n");'); return(0) }, virtual=TRUE ) - ), + ), calculateDiff_impl = nFunction( name = "calculateDiff_impl", function(instrList) { @@ -168,32 +172,37 @@ modelBase_nClass <- nClass( compileInfo = list( C_fun = function(instrList = 'nList(instr_nClass)') { ## NOTE: instrList input will be ordered. - cppLiteral('modelClass_::calculateDiff(instrList);') + cppLiteral('Rprintf("modelBase_nClass calculateDiff_impl (should not see this)\\n");'); return(0) }, virtual=TRUE ) - ), - simulate_impl = nFunction( - name = "simulate_impl", + ), + getLogProb_impl = nFunction( + name = "getLogProb_impl", function(instrList) { - cat("Uncompiled `simulate_impl` should never be called.\n") + cat("Uncompiled `getLogProb_impl` should never be called.\n") + return(0) }, + returnType = 'numericScalar', compileInfo = list( C_fun = function(instrList = 'nList(instr_nClass)') { - cppLiteral('modelClass_::simulate(instrList);') + ## NOTE: instrList input will be ordered. + cppLiteral('Rprintf("modelBase_nClass getLogProb_impl (should not see this)\\n");'); return(0) }, virtual=TRUE ) ), - getLogProb_impl = nFunction( - name = "getLogProb_impl", + simulate_impl = nFunction( + name = "simulate_impl", function(instrList) { - cat("Uncompiled `getLogProb_impl` should never be called.\n") + cat("Uncompiled `simulate_impl` should never be called.\n") + return(invisible(NULL)) }, - returnType = 'numericScalar', + returnType = 'void', compileInfo = list( C_fun = function(instrList = 'nList(instr_nClass)') { - cppLiteral('modelClass_::getLogProb(instrList);') + ## NOTE: instrList input will be ordered. + cppLiteral('Rprintf("modelBase_nClass simulate_impl (should not see this)\\n");'); }, virtual=TRUE ) @@ -203,8 +212,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('"declFunBase_nClass_c_.h","instr_nClass_c_.h"'), - needed_units = list("declFunBase_nClass","instr_nClass"), + 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..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", @@ -222,12 +227,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)) @@ -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/.DS_Store b/nimbleModel/inst/include/nimbleModel/.DS_Store new file mode 100644 index 0000000..c4c1caa Binary files /dev/null and b/nimbleModel/inst/include/nimbleModel/.DS_Store differ diff --git a/nimbleModel/inst/include/nimbleModel/predef/.DS_Store b/nimbleModel/inst/include/nimbleModel/predef/.DS_Store new file mode 100644 index 0000000..dead564 Binary files /dev/null and b/nimbleModel/inst/include/nimbleModel/predef/.DS_Store differ 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..fdc948f --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_cppContent.cpp @@ -0,0 +1,67 @@ +/* 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)]] +// [[Rcpp::depends(nimbleModel)]] + + bool declFunBase_nClass::ping ( ) { +RESET_EIGEN_ERRORS +return(true); +} + double declFunBase_nClass::calculate_cpp ( std::shared_ptr instr ) { +RESET_EIGEN_ERRORS +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::getLogProb_cpp ( std::shared_ptr instr ) { +RESET_EIGEN_ERRORS +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 +} + +// [[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_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/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..fe06f27 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_hContent.h @@ -0,0 +1,27 @@ +/* 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_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 ( ) ; +}; + + void set_CnClass_env_declFunBase_nClass ( SEXP env ) ; + + Rcpp::Environment get_CnClass_env_declFunBase_nClass ( ) ; + +#include + +#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..72394be --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/declFunBase_nC/declFunBase_nClass_manifest.txt @@ -0,0 +1,7 @@ +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", + 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/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/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..66a0779 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_cppContent.cpp @@ -0,0 +1,54 @@ +/* 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 +values = nClass_builder()(); +} + +// [[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..a3aa3c2 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/instr_nClass/instr_nClass_manifest.txt @@ -0,0 +1,7 @@ +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", + 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..d545f78 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_cppContent.cpp @@ -0,0 +1,78 @@ +/* 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)]] +// [[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 +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 +} + +// [[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("makeCompiledInstrList", &modelBase_nClass::makeCompiledInstrList, args({{arg("input",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/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..6422f2a --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_hContent.h @@ -0,0 +1,32 @@ +/* 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" +#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 ) ; + 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; +}; + + void set_CnClass_env_modelBase_nClass ( SEXP env ) ; + + Rcpp::Environment get_CnClass_env_modelBase_nClass ( ) ; + +#include + +#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..01c4ca6 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/modelBase_nC/modelBase_nClass_manifest.txt @@ -0,0 +1,7 @@ +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", + 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/inst/include/nimbleModel/predef/modelClass_/modelClass_.h b/nimbleModel/inst/include/nimbleModel/predef/modelClass_/modelClass_.h new file mode 100644 index 0000000..04db667 --- /dev/null +++ b/nimbleModel/inst/include/nimbleModel/predef/modelClass_/modelClass_.h @@ -0,0 +1,174 @@ +// 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 > declFunPtrs; + std::map name2index_map; + 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()); + Derived *self = static_cast(this); + const auto& name2access = self->get_name2access(); + declFunPtrs.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, declFunPtrs.size()); + declFunPtrs.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. + // 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); + auto i_n2a = name2access.begin(); + auto end_n2a = name2access.end(); + 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()); + 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"); + declFunPtrs.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 4889788..4a89c34 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -9,24 +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, 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 +## # "#include " in the hContent +## # And add "// [[Rcpp::depends(nimbleModel)]]" to the cppContent ## # 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, +## # "#include " to the hContent +## # And add "// [[Rcpp::depends(nimbleModel)]]" to the cppContent ## # 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) +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({ @@ -42,7 +123,82 @@ 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('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? + + # 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<