Extract the C code from a SimInf_model object
Examples
## Use the model parser to create a 'SimInf_model' object that
## expresses an SIR model, where 'b' is the transmission rate and
## 'g' is the recovery rate.
model <- mparse(transitions = c("S -> b*S*I/(S+I+R) -> I", "I -> g*I -> R"),
compartments = c("S", "I", "R"),
gdata = c(b = 0.16, g = 0.077),
u0 = data.frame(S = 99, I = 1, R = 0),
tspan = 1:10)
## View the C code.
C_code(model)
#> [1] "/* Generated by SimInf (v9.8.1.9000) */"
#> [2] ""
#> [3] "#include <R_ext/Rdynload.h>"
#> [4] "#include \"SimInf.h\""
#> [5] ""
#> [6] "/**"
#> [7] " * Make sure the necessary macros are defined so that the"
#> [8] " * compiler can replace them when compiling the model."
#> [9] " * 'SIMINF_MODEL_RUN' defines the function name of the function"
#> [10] " * that will be called from R to run a trajectory of the model."
#> [11] " * 'SIMINF_R_INIT' is the name of the function that R will call"
#> [12] " * when this model is loaded into R. 'SIMINF_FORCE_SYMBOLS'"
#> [13] " * defines whether R allows the entry point for the run function"
#> [14] " * to be searched for as a character string."
#> [15] " * If this file is compiled from SimInf (when calling run), the"
#> [16] " * macros are defined by SimInf before calling 'R CMD SHLIB'."
#> [17] " * If this file is compiled as part of a package, then the"
#> [18] " * definitions are set in the variable 'PKG_CPPFLAGS' in"
#> [19] " * 'src/Makevars' and 'src/Makevars.in'."
#> [20] " */"
#> [21] "#if !defined(SIMINF_MODEL_RUN)"
#> [22] "# error Definition for 'SIMINF_MODEL_RUN' is missing."
#> [23] "#endif"
#> [24] "#if !defined(SIMINF_R_INIT)"
#> [25] "# error Definition for 'SIMINF_R_INIT' is missing."
#> [26] "#endif"
#> [27] "#if !defined(SIMINF_FORCE_SYMBOLS)"
#> [28] "# error Definition for 'SIMINF_FORCE_SYMBOLS' is missing."
#> [29] "#endif"
#> [30] ""
#> [31] "/**"
#> [32] " * @param u The compartment state vector in the node."
#> [33] " * @param v The continuous state vector in the node."
#> [34] " * @param ldata The local data vector in the node."
#> [35] " * @param gdata The global data vector."
#> [36] " * @param t Current time."
#> [37] " * @return propensity."
#> [38] " */"
#> [39] "static double trFun1("
#> [40] " const int *u,"
#> [41] " const double *v,"
#> [42] " const double *ldata,"
#> [43] " const double *gdata,"
#> [44] " double t)"
#> [45] "{"
#> [46] " return gdata[0]*u[0]*u[1]/(u[0]+u[1]+u[2]);"
#> [47] "}"
#> [48] ""
#> [49] "/**"
#> [50] " * @param u The compartment state vector in the node."
#> [51] " * @param v The continuous state vector in the node."
#> [52] " * @param ldata The local data vector in the node."
#> [53] " * @param gdata The global data vector."
#> [54] " * @param t Current time."
#> [55] " * @return propensity."
#> [56] " */"
#> [57] "static double trFun2("
#> [58] " const int *u,"
#> [59] " const double *v,"
#> [60] " const double *ldata,"
#> [61] " const double *gdata,"
#> [62] " double t)"
#> [63] "{"
#> [64] " return gdata[1]*u[1];"
#> [65] "}"
#> [66] ""
#> [67] "/**"
#> [68] " * Post time step function."
#> [69] " *"
#> [70] " * @param v_new If a continuous state vector is used by a model,"
#> [71] " * this is the new continuous state vector in the node after"
#> [72] " * the post time step."
#> [73] " * @param u The compartment state vector in the node."
#> [74] " * @param v The current continuous state vector in the node."
#> [75] " * @param ldata The local data vector in the node."
#> [76] " * @param gdata The global data vector that is common to all nodes."
#> [77] " * @param node The node index. Note the node index is zero-based,"
#> [78] " * i.e., the first node is 0."
#> [79] " * @param t Current time in the simulation."
#> [80] " * @return error code (<0), or 1 if node needs to update the"
#> [81] " * transition rates, or 0 when it doesn't need to update"
#> [82] " * the transition rates."
#> [83] " */"
#> [84] "static int ptsFun("
#> [85] " double *v_new,"
#> [86] " const int *u,"
#> [87] " const double *v,"
#> [88] " const double *ldata,"
#> [89] " const double *gdata,"
#> [90] " int node,"
#> [91] " double t)"
#> [92] "{"
#> [93] " return 0;"
#> [94] "}"
#> [95] ""
#> [96] "/**"
#> [97] " * Run a trajectory of the model."
#> [98] " *"
#> [99] " * @param model The model."
#> [100] " * @param solver The name of the numerical solver."
#> [101] " * @return A model with a trajectory attached to it."
#> [102] " */"
#> [103] "static SEXP SIMINF_MODEL_RUN(SEXP model, SEXP solver)"
#> [104] "{"
#> [105] " static SEXP(*SimInf_run)(SEXP, SEXP, TRFun*, PTSFun) = NULL;"
#> [106] " TRFun tr_fun[] = {&trFun1, &trFun2};"
#> [107] ""
#> [108] " if (!SimInf_run) {"
#> [109] " SimInf_run = (SEXP(*)(SEXP, SEXP, TRFun*, PTSFun))"
#> [110] " R_GetCCallable(\"SimInf\", \"SimInf_run\");"
#> [111] ""
#> [112] " if (!SimInf_run) {"
#> [113] " Rf_error(\"Cannot find function 'SimInf_run'.\");"
#> [114] " }"
#> [115] " }"
#> [116] ""
#> [117] " return SimInf_run(model, solver, tr_fun, &ptsFun);"
#> [118] "}"
#> [119] ""
#> [120] "/**"
#> [121] " * A NULL-terminated array of routines to register for the .Call"
#> [122] " * interface, see section '5.4 Registering native routines' in"
#> [123] " * the 'Writing R Extensions' manual."
#> [124] " */"
#> [125] "static const R_CallMethodDef callMethods[] ="
#> [126] "{"
#> [127] " SIMINF_CALLDEF(SIMINF_MODEL_RUN, 2),"
#> [128] " {NULL, NULL, 0}"
#> [129] "};"
#> [130] ""
#> [131] "/**"
#> [132] " * This routine will be invoked when R loads the shared object/DLL,"
#> [133] " * see section '5.4 Registering native routines' in the"
#> [134] " * 'Writing R Extensions' manual."
#> [135] " */"
#> [136] "void SIMINF_R_INIT(DllInfo *info)"
#> [137] "{"
#> [138] " R_registerRoutines(info, NULL, callMethods, NULL, NULL);"
#> [139] " R_useDynamicSymbols(info, FALSE);"
#> [140] " R_forceSymbols(info, SIMINF_FORCE_SYMBOLS);"
#> [141] "}"