void R_dot_Last(void)
{
SEXP cmd;
/* Run the .Last function. */
/* Errors here should kick us back into the repl. */
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
PROTECT(cmd = install(".Last"));
R_CurrentExpr = findVar(cmd, R_GlobalEnv);
if (R_CurrentExpr != R_UnboundValue && TYPEOF(R_CurrentExpr) == CLOSXP) {
PROTECT(R_CurrentExpr = lang1(cmd));
R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
UNPROTECT(1);
}
UNPROTECT(1);
PROTECT(cmd = install(".Last.sys"));
R_CurrentExpr = findVar(cmd, R_BaseNamespace);
if (R_CurrentExpr != R_UnboundValue && TYPEOF(R_CurrentExpr) == CLOSXP) {
PROTECT(R_CurrentExpr = lang1(cmd));
R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
UNPROTECT(1);
}
UNPROTECT(1);
}
void TestLanguage::testReadWrite() {
QString fname("language.dat");
{
Language lang1(::LANGUAGE_RUSSIAN);
QVERIFY(lang1.isValid());
QFile file(fname);
file.open(QIODevice::WriteOnly);
QDataStream out(&file);
out << lang1;
}
{
Language lang2(10000);
QVERIFY(!lang2.isValid());
QFile file(fname);
file.open(QIODevice::ReadOnly);
QDataStream in(&file);
in >> lang2;
QVERIFY(lang2.isValid());
QCOMPARE(lang2.code(), (int) ::LANGUAGE_RUSSIAN);
QCOMPARE(lang2.name(), QString("Russian"));
}
}
void initVP(pGEDevDesc dd)
{
SEXP vpfnname, vpfn, vp;
SEXP xscale, yscale;
SEXP currentgp = gridStateElement(dd, GSS_GPAR);
SEXP gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
PROTECT(vpfnname = findFun(install("grid.top.level.vp"), R_gridEvalEnv));
PROTECT(vpfn = lang1(vpfnname));
PROTECT(vp = eval(vpfn, R_GlobalEnv));
/*
* Set the "native" scale of the top viewport to be the
* natural device coordinate system (e.g., points in
* postscript, pixels in X11, ...)
*/
PROTECT(xscale = allocVector(REALSXP, 2));
REAL(xscale)[0] = dd->dev->left;
REAL(xscale)[1] = dd->dev->right;
SET_VECTOR_ELT(vp, VP_XSCALE, xscale);
PROTECT(yscale = allocVector(REALSXP, 2));
REAL(yscale)[0] = dd->dev->bottom;
REAL(yscale)[1] = dd->dev->top;
SET_VECTOR_ELT(vp, VP_YSCALE, yscale);
SET_VECTOR_ELT(vp, PVP_GPAR, currentgp);
vp = doSetViewport(vp, TRUE, TRUE, dd);
SET_VECTOR_ELT(gsd, GSS_VP, vp);
UNPROTECT(5);
}
pGEDevDesc GEcurrentDevice(void)
{
/* If there are no active devices
* check the options for a "default device".
* If there is one, start it up. */
if (NoDevices()) {
SEXP defdev = GetOption1(install("device"));
if (isString(defdev) && length(defdev) > 0) {
SEXP devName = install(CHAR(STRING_ELT(defdev, 0)));
/* Not clear where this should be evaluated, since
grDevices need not be in the search path.
So we look for it first on the global search path.
*/
defdev = findVar(devName, R_GlobalEnv);
if(defdev != R_UnboundValue) {
PROTECT(defdev = lang1(devName));
eval(defdev, R_GlobalEnv);
UNPROTECT(1);
} else {
/* Not globally visible:
try grDevices namespace if loaded.
The option is unlikely to be set if it is not loaded,
as the default setting is in grDevices:::.onLoad.
*/
SEXP ns = findVarInFrame(R_NamespaceRegistry,
install("grDevices"));
if(ns != R_UnboundValue &&
findVar(devName, ns) != R_UnboundValue) {
PROTECT(defdev = lang1(devName));
eval(defdev, ns);
UNPROTECT(1);
} else
error(_("no active or default device"));
}
} else if(TYPEOF(defdev) == CLOSXP) {
PROTECT(defdev = lang1(defdev));
eval(defdev, R_GlobalEnv);
UNPROTECT(1);
} else
error(_("no active or default device"));
}
return R_Devices[R_CurrentDevice];
}
SEXP bfork_fork(SEXP fn) {
SEXP res;
pid_t pid;
if((pid = fork()) == 0) {
PROTECT(res = eval(lang1(fn), R_GlobalEnv));
PROTECT(res = eval(lang2(install("q"), mkString("no")), R_GlobalEnv));
UNPROTECT(2);
}
return ScalarInteger(pid);
}
int R_sys_getpid()
{
SEXP sys_pid, e1;
int errorOccurred;
PROTECT(e1 = lang1(install("Sys.getpid") ) );
PROTECT(sys_pid = R_tryEval(e1, R_GlobalEnv, &errorOccurred) );
int* sys_pid_r = INTEGER(sys_pid);
int ret =sys_pid_r[0];
UNPROTECT(2);
return(ret);
}
static char *R_completion_generator(const char *text, int state)
{
static int list_index, ncomp;
static char **compstrings;
/* If this is a new word to complete, initialize now. This
involves saving 'text' to somewhere R can get at it, calling
completeToken(), and retrieving the completions. */
if (!state) {
int i;
SEXP completions,
assignCall = PROTECT(lang2(RComp_assignTokenSym, mkString(text))),
completionCall = PROTECT(lang1(RComp_completeTokenSym)),
retrieveCall = PROTECT(lang1(RComp_retrieveCompsSym));
const void *vmax = vmaxget();
eval(assignCall, rcompgen_rho);
eval(completionCall, rcompgen_rho);
PROTECT(completions = eval(retrieveCall, rcompgen_rho));
list_index = 0;
ncomp = length(completions);
if (ncomp > 0) {
compstrings = (char **) malloc(ncomp * sizeof(char*));
if (!compstrings) return (char *)NULL;
for (i = 0; i < ncomp; i++)
compstrings[i] = strdup(translateChar(STRING_ELT(completions, i)));
}
UNPROTECT(4);
vmaxset(vmax);
}
if (list_index < ncomp)
return compstrings[list_index++];
else {
/* nothing matched or remaining, so return NULL. */
if (ncomp > 0) free(compstrings);
}
return (char *)NULL;
}
SEXP GillespieDirectCR(SEXP pre, SEXP post, SEXP h, SEXP M, SEXP T, SEXP delta,
SEXP runs, SEXP place, SEXP transition, SEXP rho)
{
int k;
#ifdef RB_TIME
clock_t c0, c1;
c0 = clock();
#endif
// Get dimensions of pre
int *piTmp = INTEGER(getAttrib(pre, R_DimSymbol));
int iTransitions = piTmp[0], iPlaces = piTmp[1];
int *piPre = INTEGER(pre), *piPost = INTEGER(post);
SEXP sexpTmp;
int iTransition, iPlace, iTransitionPtr, iPlacePtr,
iTransition2, iTransitionPtr2;
// Find out which elements of h are doubles and which functions
SEXP sexpFunction;
PROTECT(sexpFunction = allocVector(VECSXP, iTransitions));
double *pdH = (double *) R_alloc(iTransitions, sizeof(double));
DL_FUNC *pCFunction = (DL_FUNC *) R_alloc(iTransitions, sizeof(DL_FUNC *));
int *piHzType = (int *) R_alloc(iTransitions, sizeof(int));
for (iTransition = 0; iTransition < iTransitions; iTransition++) {
if (inherits(sexpTmp = VECTOR_ELT(h, iTransition), "NativeSymbol")) {
pCFunction[iTransition] = (void *) R_ExternalPtrAddr(sexpTmp);
piHzType[iTransition] = HZ_CFUNCTION;
} else if (isNumeric(sexpTmp)){
pdH[iTransition] = REAL(sexpTmp)[0];
piHzType[iTransition] = HZ_DOUBLE;
} else if (isFunction(sexpTmp)) {
SET_VECTOR_ELT(sexpFunction, iTransition, lang1(sexpTmp));
piHzType[iTransition] = HZ_RFUNCTION;
} else {
error("Unrecongnized transition function type\n");
}
}
// Setup Matrix S
int *piS = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Position of non zero cells in pre per transition
int *piPreNZxRow = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Totals of non zero cells in pre per transition
int *piPreNZxRowTot = (int *) R_alloc(iTransitions, sizeof(int));
// Position of non zero cells in S per transition
int *piSNZxRow = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Totals of non zero cells in S per transition
int *piSNZxRowTot = (int *) R_alloc(iTransitions, sizeof(int));
for (iTransition = 0; iTransition < iTransitions; iTransition++) {
int iPreNZxRow_col = 0;
int iSNZxRow_col = 0;
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
if (piPre[iTransition + iTransitions * iPlace]) {
piPreNZxRow[iTransition + iTransitions * iPreNZxRow_col++] = iPlace;
}
if ((piS[iTransition + iTransitions * iPlace] =
piPost[iTransition + iTransitions * iPlace] - piPre[iTransition + iTransitions * iPlace])) {
piSNZxRow[iTransition + iTransitions * iSNZxRow_col++] = iPlace;
}
}
piPreNZxRowTot[iTransition] = iPreNZxRow_col;
piSNZxRowTot[iTransition] = iSNZxRow_col;
}
// Position of non zero cells in pre per place
int *piPreNZxCol = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Totals of non zero cells in pre per place
int *piPreNZxColTot = (int *) R_alloc(iPlaces, sizeof(int));
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
int iPreNZxCol_row = 0;
for (iTransition = 0; iTransition < iTransitions; iTransition++) {
if (piPre[iTransition + iTransitions * iPlace]) {
piPreNZxCol[iPreNZxCol_row++ + iTransitions * iPlace] = iTransition;
}
}
piPreNZxColTot[iPlace] = iPreNZxCol_row;
}
// Hazards that need to be recalculated if a given transition has happened
int *piHazardsToModxRow = (int *) R_alloc((iTransitions + 1) * iTransitions, sizeof(int));
// Totals of hazards to recalculate for each transition that has happened
int *piHazardsToModxRowTot = (int *) R_alloc(iTransitions + 1, sizeof(int));
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
int iHazardToCompTot = 0;
for(iPlace = 0; iPlace < iPlaces; iPlace++) {
if (piS[iTransition + iTransitions * iPlace]) {
// Identify the transitions that need the hazards recalculated
for(iTransitionPtr2 = 0; iTransitionPtr2 < piPreNZxColTot[iPlace]; iTransitionPtr2++) {
iTransition2 = piPreNZxCol[iTransitionPtr2 + iTransitions * iPlace];
int iAddThis = TRUE;
for (k = 0; k < iHazardToCompTot; k++) {
if(piHazardsToModxRow[iTransition + (iTransitions + 1) * k] == iTransition2) {
iAddThis = FALSE;
break;
}
}
if (iAddThis)
piHazardsToModxRow[iTransition + (iTransitions + 1) * iHazardToCompTot++] = iTransition2;
}
}
}
piHazardsToModxRowTot[iTransition] = iHazardToCompTot;
}
// For the initial calculation of all hazards...
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
piHazardsToModxRow[iTransitions + (iTransitions + 1) * iTransition] = iTransition;
}
piHazardsToModxRowTot[iTransitions] = iTransitions;
SEXP sexpCrntMarking;
PROTECT(sexpCrntMarking = allocVector(REALSXP, iPlaces));
double *pdCrntMarking = REAL(sexpCrntMarking);
double dDelta = *REAL(delta);
int iTotalSteps, iSectionSteps;
double dT = 0;
void *pCManage_time = 0;
SEXP sexpRManage_time = 0;
if (inherits(T, "NativeSymbol")) {
pCManage_time = (void *) R_ExternalPtrAddr(T);
dT = ((double(*)(double, double *)) pCManage_time)(-1, pdCrntMarking);
} else if (isNumeric(T)){
dT = *REAL(T);
} else if (isFunction(T)) {
PROTECT(sexpRManage_time = lang1(T));
defineVar(install("y"), sexpCrntMarking, rho);
PROTECT(sexpTmp = allocVector(REALSXP, 1));
*REAL(sexpTmp) = -1;
defineVar(install("StartTime"), sexpTmp, rho);
UNPROTECT_PTR(sexpTmp);
dT = *REAL(VECTOR_ELT(eval(sexpRManage_time, rho),0));
} else {
error("Unrecognized time function type\n");
}
iTotalSteps = iSectionSteps = (int)(dT / dDelta) + 1;
int iRun, iRuns = *INTEGER(runs);
// Hazard vector
double *pdTransitionHazard = (double *) R_alloc(iTransitions, sizeof(double));
SEXP sexpRun;
PROTECT(sexpRun = allocVector(VECSXP, iRuns));
int iTotalUsedRandomNumbers = 0;
// DiscTime Vector
SEXP sexpD_time;
PROTECT(sexpD_time = allocVector(REALSXP, iTotalSteps));
double *pdDiscTime = REAL(sexpD_time);
double dTmp = 0;
for (k = 0; k < iTotalSteps; k++) {
pdDiscTime[k] = dTmp;
dTmp += dDelta;
}
SEXP sexpMarkingRowNames;
PROTECT(sexpMarkingRowNames = allocVector(INTSXP, iTotalSteps));
piTmp = INTEGER(sexpMarkingRowNames);
for (k = 0; k < iTotalSteps; k++)
piTmp[k] = k+1;
double **ppdMarking = (double **) R_alloc(iPlaces, sizeof(double *));
int iLevels = 7;
int iGroups = pow(2, iLevels - 1);
// Group holding the transitions that lie between boundaries
int **ppiGroup = (int **) R_alloc(iGroups, sizeof(int *));
// Number of transition each group has
int *piGroupElm = (int *) R_alloc(iGroups, sizeof(int));
// Total propensity hazard for each group
int *piTotGroupTransitions = (int *) R_alloc(iGroups, sizeof(int));
int *piTransitionInGroup = (int *) R_alloc(iTransitions, sizeof(int));
int *piTransitionPositionInGroup = (int *) R_alloc(iTransitions, sizeof(int));
int iGroup;
for (iGroup = 0; iGroup < iGroups; iGroup++) {
ppiGroup[iGroup] = (int *) R_alloc(iTransitions, sizeof(int));
}
node **ppnodeLevel = (node **) R_alloc(iLevels, sizeof(node *));
int iLevel, iNode;
int iNodesPerLevel = 1;
for (iLevel = 0; iLevel < iLevels; iLevel++) {
ppnodeLevel[iLevel] = (node *) R_alloc(iNodesPerLevel, sizeof(node));
iNodesPerLevel *= 2;
}
node *pnodeRoot = &ppnodeLevel[0][0];
pnodeRoot->parent = 0;
node *pnodeGroup = ppnodeLevel[iLevels-1];
iNodesPerLevel = 1;
for (iLevel = 0; iLevel < iLevels; iLevel++) {
for (iNode = 0; iNode < iNodesPerLevel; iNode++) {
if (iLevel < iLevels-1) {
ppnodeLevel[iLevel][iNode].iGroup = -1;
ppnodeLevel[iLevel][iNode].left = &ppnodeLevel[iLevel+1][iNode*2];
ppnodeLevel[iLevel][iNode].right = &ppnodeLevel[iLevel+1][iNode*2+1];
ppnodeLevel[iLevel+1][iNode*2].parent = ppnodeLevel[iLevel+1][iNode*2+1].parent =
&ppnodeLevel[iLevel][iNode];
} else {
ppnodeLevel[iLevel][iNode].iGroup = iNode;
ppnodeLevel[iLevel][iNode].left = ppnodeLevel[iLevel][iNode].right = 0;
}
}
iNodesPerLevel *= 2;
}
double dNewHazard = 0;
// Find minimum propensity
double dMinHazard = DBL_MAX;
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
switch(piHzType[iTransition]) {
case HZ_DOUBLE:
dNewHazard = pdH[iTransition];
for(iPlacePtr = 0; iPlacePtr < piPreNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piPreNZxRow[iTransition + iTransitions * iPlacePtr];
for (k = 0; k < piPre[iTransition + iTransitions * iPlace]; k++)
dNewHazard *= (piPre[iTransition + iTransitions * iPlace] - k) / (double)(k+1);
}
if (dNewHazard > 0 && dNewHazard < dMinHazard)
dMinHazard = dNewHazard;
break;
case HZ_CFUNCTION:
break;
case HZ_RFUNCTION:
break;
}
}
GetRNGstate();
for (iRun = 0; iRun < iRuns; iRun++) {
int iUsedRandomNumbers = 0;
Rprintf("%d ", iRun+1);
// Totals for kind of transition vector
SEXP sexpTotXTransition;
PROTECT(sexpTotXTransition = allocVector(INTSXP, iTransitions));
int *piTotTransitions = INTEGER(sexpTotXTransition);
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
piTotTransitions[iTransition] = 0;
}
SEXP sexpMarking;
PROTECT(sexpMarking = allocVector(VECSXP, iPlaces));
//setAttrib(sexpMarking, R_NamesSymbol, place);
//setAttrib(sexpMarking, R_RowNamesSymbol, sexpMarkingRowNames);
//setAttrib(sexpMarking, R_ClassSymbol, ScalarString(mkChar("data.frame")));
// Setup initial state
double *pdTmp = REAL(M);
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
SET_VECTOR_ELT(sexpMarking, iPlace, sexpTmp = allocVector(REALSXP, iTotalSteps));
ppdMarking[iPlace] = REAL(sexpTmp);
pdCrntMarking[iPlace] = pdTmp[iPlace];
}
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
pdTransitionHazard[iTransition] = 0;
piTransitionInGroup[iTransition] = -1;
}
for (iGroup = 0; iGroup < iGroups; iGroup++) {
piGroupElm[iGroup] = 0;
piTotGroupTransitions[iGroup] = 0;
}
iNodesPerLevel = 1;
for (iLevel = 0; iLevel < iLevels; iLevel++) {
for (iNode = 0; iNode < iNodesPerLevel; iNode++) {
ppnodeLevel[iLevel][iNode].dPartialAcumHazard = 0;
}
iNodesPerLevel *= 2;
}
node *pnode;
double dTime = 0, dTarget = 0;
int iTotTransitions = 0;
int iStep = 0;
int iInterruptCnt = 10000000;
do {
if (pCManage_time || sexpRManage_time) {
double dEnd = 0;
if (pCManage_time) {
dEnd = ((double(*)(double, double *)) pCManage_time)(dTarget, pdCrntMarking);
} else {
defineVar(install("y"), sexpCrntMarking, rho);
PROTECT(sexpTmp = allocVector(REALSXP, 1));
*REAL(sexpTmp) = dTarget;
defineVar(install("StartTime"), sexpTmp, rho);
UNPROTECT_PTR(sexpTmp);
sexpTmp = eval(sexpRManage_time, rho);
dEnd = *REAL(VECTOR_ELT(sexpTmp,0));
for(iPlace = 0; iPlace < iPlaces; iPlace++) {
pdCrntMarking[iPlace] = REAL(VECTOR_ELT(sexpTmp,1))[iPlace];
}
}
iSectionSteps = (int)(dEnd / dDelta) + 1;
}
for(iPlace = 0; iPlace < iPlaces; iPlace++) {
ppdMarking[iPlace][iStep] = pdCrntMarking[iPlace];
}
dTime = dTarget;
dTarget += dDelta;
// For the calculation of all hazards...
int iLastTransition = iTransitions;
do {
// Get hazards only for the transitions associated with
// places whose quantities changed in the last step.
for(iTransitionPtr = 0; iTransitionPtr < piHazardsToModxRowTot[iLastTransition]; iTransitionPtr++) {
iTransition = piHazardsToModxRow[iLastTransition + (iTransitions + 1) * iTransitionPtr];
switch(piHzType[iTransition]) {
case HZ_DOUBLE:
dNewHazard = pdH[iTransition];
for(iPlacePtr = 0; iPlacePtr < piPreNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piPreNZxRow[iTransition + iTransitions * iPlacePtr];
for (k = 0; k < piPre[iTransition + iTransitions * iPlace]; k++)
dNewHazard *= (pdCrntMarking[iPlace] - k) / (double)(k+1);
}
break;
case HZ_CFUNCTION:
dNewHazard = ((double(*)(double, double *)) pCFunction[iTransition])(dTime, pdCrntMarking);
break;
case HZ_RFUNCTION:
defineVar(install("y"), sexpCrntMarking, rho);
dNewHazard = REAL(eval(VECTOR_ELT(sexpFunction, iTransition), rho))[0];
break;
}
double dDeltaHazard;
frexp(dNewHazard/dMinHazard, &iGroup);
if (iGroup-- > 0) {
// Transition belongs to a group
if (iGroup == piTransitionInGroup[iTransition]) {
// Transitions will stay in same group as it was
dDeltaHazard = dNewHazard - pdTransitionHazard[iTransition];
pnode = &pnodeGroup[iGroup];
do {
pnode->dPartialAcumHazard += dDeltaHazard;
} while ((pnode = pnode->parent));
} else if (piTransitionInGroup[iTransition] != -1) {
// Transition was in another group and needs to be moved to the new one
int iOldGroup = piTransitionInGroup[iTransition];
int iOldPositionInGroup = piTransitionPositionInGroup[iTransition];
dDeltaHazard = -pdTransitionHazard[iTransition];
pnode = &pnodeGroup[iOldGroup];
do {
pnode->dPartialAcumHazard += dDeltaHazard;
} while ((pnode = pnode->parent));
piGroupElm[iOldGroup]--; // Old group will have one less element
// Now, piGroupElm[iOldGroup] is the index to last transition in group
if (iOldPositionInGroup != piGroupElm[iOldGroup]) {
// Transition is not the last in group,
// put the last transition in place of the one to be removed
ppiGroup[iOldGroup][iOldPositionInGroup] =
ppiGroup[iOldGroup][piGroupElm[iOldGroup]];
// Update position of previous last transition in group
piTransitionPositionInGroup[ppiGroup[iOldGroup][iOldPositionInGroup]] =
iOldPositionInGroup;
}
dDeltaHazard = dNewHazard;
pnode = &pnodeGroup[iGroup];
do {
pnode->dPartialAcumHazard += dDeltaHazard;
} while ((pnode = pnode->parent));
piTransitionInGroup[iTransition] = iGroup;
piTransitionPositionInGroup[iTransition] = piGroupElm[iGroup];
ppiGroup[iGroup][piGroupElm[iGroup]++] = iTransition;
} else if (piTransitionInGroup[iTransition] == -1) { // Transition was in no group
dDeltaHazard = dNewHazard;
pnode = &pnodeGroup[iGroup];
do {
pnode->dPartialAcumHazard += dDeltaHazard;
} while ((pnode = pnode->parent));
piTransitionInGroup[iTransition] = iGroup;
piTransitionPositionInGroup[iTransition] = piGroupElm[iGroup];
ppiGroup[iGroup][piGroupElm[iGroup]++] = iTransition;
} else {
error("ERROR: Option not considered 1\n");
}
} else if (piTransitionInGroup[iTransition] != -1) {
// Transition will not belong to any group and needs to be removed from old
int iOldGroup = piTransitionInGroup[iTransition];
int iOldPositionInGroup = piTransitionPositionInGroup[iTransition];
dDeltaHazard = -pdTransitionHazard[iTransition];
pnode = &pnodeGroup[iOldGroup];
do {
pnode->dPartialAcumHazard += dDeltaHazard;
} while ((pnode = pnode->parent));
piGroupElm[iOldGroup]--; // Old group will have one less element
// Now, piGroupElm[iOldGroup] is the index to last transition in group
if (iOldPositionInGroup != piGroupElm[iOldGroup]) {
// Transition is not the last in group,
// put the last transition in place of the one to be removed
ppiGroup[iOldGroup][iOldPositionInGroup] =
ppiGroup[iOldGroup][piGroupElm[iOldGroup]];
// Update position of previous last transition in group
piTransitionPositionInGroup[ppiGroup[iOldGroup][iOldPositionInGroup]] =
iOldPositionInGroup;
}
piTransitionInGroup[iTransition] = -1;
}
pdTransitionHazard[iTransition] = dNewHazard;
}
// Get Time to transition
dTime += exp_rand() / pnodeRoot->dPartialAcumHazard;
iUsedRandomNumbers++;
while (dTime >= dTarget) {
++iStep;
// Update the state for the fixed incremented time.
for(iPlace = 0; iPlace < iPlaces; iPlace++)
ppdMarking[iPlace][iStep] = pdCrntMarking[iPlace];
if (iStep == iSectionSteps - 1)
goto EXIT_LOOP;
dTarget += dDelta;
// Force check if user interrupted
iInterruptCnt = 1;
}
if (! --iInterruptCnt) {
// Allow user interruption
R_CheckUserInterrupt();
iInterruptCnt = 10000000;
}
do {
// Find group containing firing transition
double dRnd = unif_rand() * pnodeRoot->dPartialAcumHazard;
iUsedRandomNumbers++;
pnode = pnodeRoot;
do {
if (dRnd < pnode->left->dPartialAcumHazard) {
pnode = pnode->left;
} else {
dRnd -= pnode->left->dPartialAcumHazard;
pnode = pnode->right;
}
} while (pnode->left);
// Next check is because
// once in a while it is generated a number that goes past
// the last group or selects a group with zero elements
// due to accumulated truncation errors.
// Discard this random number and try again.
} while (piGroupElm[iGroup = pnode->iGroup] == 0);
double dMaxInGroup = dMinHazard * pow(2, iGroup + 1);
// Find transition in group
while (1) {
if (! --iInterruptCnt) {
// Allow user interruption
R_CheckUserInterrupt();
iInterruptCnt = 10000000;
}
iTransitionPtr = (int) (unif_rand() * piGroupElm[iGroup]);
iUsedRandomNumbers++;
iTransition = ppiGroup[iGroup][iTransitionPtr];
iUsedRandomNumbers++;
if (pdTransitionHazard[iTransition] > unif_rand() * dMaxInGroup) {
piTotTransitions[iLastTransition = iTransition]++;
for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr];
// Update the state
pdCrntMarking[iPlace] += piS[iTransition + iTransitions * iPlace];
}
break;
}
}
++iTotTransitions;
} while (TRUE);
EXIT_LOOP:;
Rprintf(".");
} while (iSectionSteps < iTotalSteps);
iTotalUsedRandomNumbers += iUsedRandomNumbers;
Rprintf("\t%d\t%d\t%d", iTotTransitions, iUsedRandomNumbers, iTotalUsedRandomNumbers);
#ifdef RB_SUBTIME
c1 = clock();
Rprintf ("\t To go: ");
PrintfTime((double) (c1 - c0)/CLOCKS_PER_SEC/(iRun+1)*(iRuns-iRun-1));
#endif
Rprintf ("\n");
SEXP sexpTotTransitions;
PROTECT(sexpTotTransitions = allocVector(INTSXP, 1));
INTEGER(sexpTotTransitions)[0] = iTotTransitions;
SEXP sexpThisRun;
PROTECT(sexpThisRun = allocVector(VECSXP, 3));
SET_VECTOR_ELT(sexpThisRun, 0, sexpMarking);
UNPROTECT_PTR(sexpMarking);
SET_VECTOR_ELT(sexpThisRun, 1, sexpTotXTransition);
UNPROTECT_PTR(sexpTotXTransition);
SET_VECTOR_ELT(sexpThisRun, 2, sexpTotTransitions);
UNPROTECT_PTR(sexpTotTransitions);
SEXP sexpNames;
PROTECT(sexpNames = allocVector(VECSXP, 3));
SET_VECTOR_ELT(sexpNames, 0, mkChar("M"));
SET_VECTOR_ELT(sexpNames, 1, mkChar("transitions"));
SET_VECTOR_ELT(sexpNames, 2, mkChar("tot.transitions"));
setAttrib(sexpThisRun, R_NamesSymbol, sexpNames);
UNPROTECT_PTR(sexpNames);
SET_VECTOR_ELT(sexpRun, iRun, sexpThisRun);
UNPROTECT_PTR(sexpThisRun);
}
PutRNGstate();
SEXP sexpAns;
PROTECT(sexpAns = allocVector(VECSXP, 4));
SET_VECTOR_ELT(sexpAns, 0, place);
SET_VECTOR_ELT(sexpAns, 1, transition);
SET_VECTOR_ELT(sexpAns, 2, sexpD_time);
UNPROTECT_PTR(sexpD_time);
SET_VECTOR_ELT(sexpAns, 3, sexpRun);
UNPROTECT_PTR(sexpRun);
SEXP sexpNames;
PROTECT(sexpNames = allocVector(VECSXP, 4));
SET_VECTOR_ELT(sexpNames, 0, mkChar("place"));
SET_VECTOR_ELT(sexpNames, 1, mkChar("transition"));
SET_VECTOR_ELT(sexpNames, 2, mkChar("dt"));
SET_VECTOR_ELT(sexpNames, 3, mkChar("run"));
setAttrib(sexpAns, R_NamesSymbol, sexpNames);
UNPROTECT_PTR(sexpNames);
#ifdef RB_TIME
c1 = clock();
double dCpuTime = (double) (c1 - c0)/CLOCKS_PER_SEC;
Rprintf ("Elapsed CPU time: ");
PrintfTime(dCpuTime);
Rprintf ("\t(%fs)\n", dCpuTime);
#endif
if (sexpRManage_time)
UNPROTECT_PTR(sexpRManage_time);
UNPROTECT_PTR(sexpFunction);
UNPROTECT_PTR(sexpMarkingRowNames);
UNPROTECT_PTR(sexpCrntMarking);
UNPROTECT_PTR(sexpAns);
return(sexpAns);
}
int main (int argc,char *argv[])
{/* Main */
double *f=NULL;
int i;
char *pp=NULL;
FILE *fout=NULL;
SEXP e, e1, rv, rs;
init_R(argc, argv);
/* Calling R and asking it to call compiled C routines! */
{
int deuce=-999;
DllInfo *info;
R_CallMethodDef callMethods[] = {
{"callback", (DL_FUNC) &callback, 1},
{NULL, NULL, 0}
};
info = R_getEmbeddingDllInfo();
R_registerRoutines(info, NULL, callMethods, NULL, NULL);
/* .Call is the R function used to call compiled
code that uses internal R objects */
PROTECT(e1=lang3( install(".Call"),
mkString("callback"),ScalarInteger(100)));
/* evaluate the R command in the global environment*/
PROTECT(e=eval(e1,R_GlobalEnv));
/* show the value */
printf("Answer returned by R:"); Rf_PrintValue(e);
/* store the value in a local variable */
deuce = INTEGER(e)[0];
printf("Got %d back from result SEXP\n\n", deuce);
UNPROTECT(2); /* allow for R's garbage collection */
}
/* Calling R and asking it to do computation on a C array */
f = (double *)malloc(sizeof(double)*256);
for (i=0; i<256;++i) f[i]=(double)rand()/(double)RAND_MAX+i/64;
/*Now copy array into R structs */
PROTECT(rv=allocVector(REALSXP, 256));
defineVar(install("f"), rv, R_GlobalEnv); /* put rv in R's environment and
name it "f" */
for (i=0; i<256;++i) REAL(rv)[i] = f[i]; /* fill rv with values */
/* plot that array with R's: plot(f) */
PROTECT(e = lang1(install("x11")));
eval(e, R_GlobalEnv);
UNPROTECT(1);
PROTECT(e=lang2(install("plot"),install("f")));
eval(e, R_GlobalEnv);
UNPROTECT(1);
/* calculate the log of the values with log(f) */
PROTECT(e1=lang2(install("log"),install("f")));
PROTECT(e=eval(e1,R_GlobalEnv));
for (i=0; i<256;++i) {
if (i<5 || i>250) {
printf("%d: log(%f)=%f\n", i, f[i], REAL(e)[i]);
} else if (!(i%20)) {
printf("...");
}
}
UNPROTECT(2);
/* Now run some R script with source(".../ExamineXmat.R") */
if (!(pp = Add_plausible_path("ExamineXmat.R"))) {
fprintf(stderr,"Failed to find ExamineXmat.R\n");
exit(1);
}
PROTECT(rs=mkString(pp));
defineVar(install("sss"), rs, R_GlobalEnv);
fprintf(stderr,"checking on script name: %s\n", STRING_VALUE(rs));
PROTECT(e=lang2(install("source"),install("sss")));
eval(e, R_GlobalEnv);
UNPROTECT(2);
fprintf(stderr,"Hit enter to proceed\n");
free(pp); pp=NULL;
/* Here is should test calling R functions from some functions
that we create. I will need to sort out how packges are formed
for R and how R can find them on any machine etc. Nuts and bolts...
A simple exercise here would be to learn how to construct our R library
and call its functions from here ... */
free(f); f = NULL; free(pp); pp=NULL;
getchar();
}
str RAPIeval(Client cntxt, MalBlkPtr mb, MalStkPtr stk, InstrPtr pci, bit grouped) {
sql_func * sqlfun = NULL;
str exprStr = *getArgReference_str(stk, pci, pci->retc + 1);
SEXP x, env, retval;
SEXP varname = R_NilValue;
SEXP varvalue = R_NilValue;
ParseStatus status;
int i = 0;
char argbuf[64];
char *argnames = NULL;
size_t argnameslen;
size_t pos;
char* rcall = NULL;
size_t rcalllen;
int ret_cols = 0; /* int because pci->retc is int, too*/
str *args;
int evalErr;
char *msg = MAL_SUCCEED;
BAT *b;
node * argnode;
int seengrp = FALSE;
rapiClient = cntxt;
if (!RAPIEnabled()) {
throw(MAL, "rapi.eval",
"Embedded R has not been enabled. Start server with --set %s=true",
rapi_enableflag);
}
if (!rapiInitialized) {
throw(MAL, "rapi.eval",
"Embedded R initialization has failed");
}
if (!grouped) {
sql_subfunc *sqlmorefun = (*(sql_subfunc**) getArgReference(stk, pci, pci->retc));
if (sqlmorefun) sqlfun = (*(sql_subfunc**) getArgReference(stk, pci, pci->retc))->func;
} else {
sqlfun = *(sql_func**) getArgReference(stk, pci, pci->retc);
}
args = (str*) GDKzalloc(sizeof(str) * pci->argc);
if (args == NULL) {
throw(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
}
// get the lock even before initialization of the R interpreter, as this can take a second and must be done only once.
MT_lock_set(&rapiLock);
env = PROTECT(eval(lang1(install("new.env")), R_GlobalEnv));
assert(env != NULL);
// first argument after the return contains the pointer to the sql_func structure
// NEW macro temporarily renamed to MNEW to allow including sql_catalog.h
if (sqlfun != NULL && sqlfun->ops->cnt > 0) {
int carg = pci->retc + 2;
argnode = sqlfun->ops->h;
while (argnode) {
char* argname = ((sql_arg*) argnode->data)->name;
args[carg] = GDKstrdup(argname);
carg++;
argnode = argnode->next;
}
}
// the first unknown argument is the group, we don't really care for the rest.
argnameslen = 2;
for (i = pci->retc + 2; i < pci->argc; i++) {
if (args[i] == NULL) {
if (!seengrp && grouped) {
args[i] = GDKstrdup("aggr_group");
seengrp = TRUE;
} else {
snprintf(argbuf, sizeof(argbuf), "arg%i", i - pci->retc - 1);
args[i] = GDKstrdup(argbuf);
}
}
argnameslen += strlen(args[i]) + 2; /* extra for ", " */
}
// install the MAL variables into the R environment
// we can basically map values to int ("INTEGER") or double ("REAL")
for (i = pci->retc + 2; i < pci->argc; i++) {
int bat_type = getBatType(getArgType(mb,pci,i));
// check for BAT or scalar first, keep code left
if (!isaBatType(getArgType(mb,pci,i))) {
b = COLnew(0, getArgType(mb, pci, i), 0, TRANSIENT);
if (b == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
if ( getArgType(mb,pci,i) == TYPE_str) {
if (BUNappend(b, *getArgReference_str(stk, pci, i), false) != GDK_SUCCEED) {
BBPreclaim(b);
b = NULL;
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
} else {
if (BUNappend(b, getArgReference(stk, pci, i), false) != GDK_SUCCEED) {
BBPreclaim(b);
b = NULL;
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
} else {
b = BATdescriptor(*getArgReference_bat(stk, pci, i));
if (b == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
// check the BAT count, if it is bigger than RAPI_MAX_TUPLES, fail
if (BATcount(b) > RAPI_MAX_TUPLES) {
msg = createException(MAL, "rapi.eval",
"Got "BUNFMT" rows, but can only handle "LLFMT". Sorry.",
BATcount(b), (lng) RAPI_MAX_TUPLES);
BBPunfix(b->batCacheid);
goto wrapup;
}
varname = PROTECT(Rf_install(args[i]));
varvalue = bat_to_sexp(b, bat_type);
if (varvalue == NULL) {
msg = createException(MAL, "rapi.eval", "unknown argument type ");
goto wrapup;
}
BBPunfix(b->batCacheid);
// install vector into R environment
Rf_defineVar(varname, varvalue, env);
UNPROTECT(2);
}
/* we are going to evaluate the user function within an anonymous function call:
* ret <- (function(arg1){return(arg1*2)})(42)
* the user code is put inside the {}, this keeps our environment clean (TM) and gives
* a clear path for return values, namely using the builtin return() function
* this is also compatible with PL/R
*/
pos = 0;
argnames = malloc(argnameslen);
if (argnames == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
argnames[0] = '\0';
for (i = pci->retc + 2; i < pci->argc; i++) {
pos += snprintf(argnames + pos, argnameslen - pos, "%s%s",
args[i], i < pci->argc - 1 ? ", " : "");
}
rcalllen = 2 * pos + strlen(exprStr) + 100;
rcall = malloc(rcalllen);
if (rcall == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
snprintf(rcall, rcalllen,
"ret <- as.data.frame((function(%s){%s})(%s), nm=NA, stringsAsFactors=F)\n",
argnames, exprStr, argnames);
free(argnames);
argnames = NULL;
#ifdef _RAPI_DEBUG_
printf("# R call %s\n",rcall);
#endif
x = R_ParseVector(mkString(rcall), 1, &status, R_NilValue);
if (LENGTH(x) != 1 || status != PARSE_OK) {
msg = createException(MAL, "rapi.eval",
"Error parsing R expression '%s'. ", exprStr);
goto wrapup;
}
retval = R_tryEval(VECTOR_ELT(x, 0), env, &evalErr);
if (evalErr != FALSE) {
char* errormsg = strdup(R_curErrorBuf());
size_t c;
if (errormsg == NULL) {
msg = createException(MAL, "rapi.eval", "Error running R expression.");
goto wrapup;
}
// remove newlines from error message so it fits into a MAPI error (lol)
for (c = 0; c < strlen(errormsg); c++) {
if (errormsg[c] == '\r' || errormsg[c] == '\n') {
errormsg[c] = ' ';
}
}
msg = createException(MAL, "rapi.eval",
"Error running R expression: %s", errormsg);
free(errormsg);
goto wrapup;
}
// ret should be a data frame with exactly as many columns as we need from retc
ret_cols = LENGTH(retval);
if (ret_cols != pci->retc) {
msg = createException(MAL, "rapi.eval",
"Expected result of %d columns, got %d", pci->retc, ret_cols);
goto wrapup;
}
// collect the return values
for (i = 0; i < pci->retc; i++) {
SEXP ret_col = VECTOR_ELT(retval, i);
int bat_type = getBatType(getArgType(mb,pci,i));
if (bat_type == TYPE_any || bat_type == TYPE_void) {
getArgType(mb,pci,i) = bat_type;
msg = createException(MAL, "rapi.eval",
"Unknown return value, possibly projecting with no parameters.");
goto wrapup;
}
// hand over the vector into a BAT
b = sexp_to_bat(ret_col, bat_type);
if (b == NULL) {
msg = createException(MAL, "rapi.eval",
"Failed to convert column %i", i);
goto wrapup;
}
// bat return
if (isaBatType(getArgType(mb,pci,i))) {
*getArgReference_bat(stk, pci, i) = b->batCacheid;
} else { // single value return, only for non-grouped aggregations
BATiter li = bat_iterator(b);
if (VALinit(&stk->stk[pci->argv[i]], bat_type,
BUNtail(li, 0)) == NULL) { // TODO BUNtail here
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
msg = MAL_SUCCEED;
}
/* unprotect environment, so it will be eaten by the GC. */
UNPROTECT(1);
wrapup:
MT_lock_unset(&rapiLock);
if (argnames)
free(argnames);
if (rcall)
free(rcall);
for (i = 0; i < pci->argc; i++)
GDKfree(args[i]);
GDKfree(args);
return msg;
}
Sampler *
sampler_new (SEXP opts)
{
Sampler *ss;
SEXP SEXPTmp;
ss = (Sampler *) R_alloc(1, sizeof(struct Sampler));
ss->nStreams = INTEGER(getListElement(opts, "nStreams"))[0];
ss->nPeriods = INTEGER(getListElement(opts, "nPeriods"))[0];
ss->nStreamsPreResamp = INTEGER(getListElement(opts, "nStreamsPreResamp"))[0];
ss->dimPerPeriod = INTEGER(getListElement(opts, "dimPerPeriod"))[0];
ss->dimSummPerPeriod = INTEGER(getListElement(opts, "dimSummPerPeriod"))[0];
ss->returnStreams = LOGICAL(getListElement(opts, "returnStreams"))[0];
ss->returnLogWeights = LOGICAL(getListElement(opts, "returnLogWeights"))[0];
ss->nMHSteps = INTEGER(getListElement(opts, "nMHSteps"))[0];
ss->verboseLevel = INTEGER(getListElement(opts, "verboseLevel"))[0];
ss->printEstTimeAt = 10; ss->printEstTimeNTimes = 10;
/* FIXME: The setting for ss->printDotAt, is it all right? */
ss->printInitialDotsWhen = ss->printEstTimeAt / 10;
ss->printDotAt = 0; ss->nDotsPerLine = 20;
ss->eachDotWorth = (int) ceil((ss->nPeriods - ss->printEstTimeAt + 1.0) / \
(ss->printEstTimeNTimes * ss->nDotsPerLine));
ss->nProtected = 0;
/* The user provided functions */
ss->propagateFunc = getListElement(opts, "propagateFunc");
ss->propagateArgsList = (ArgsList1 *) R_alloc(1, sizeof(struct ArgsList1));
ss->nProtected += args_list1_init(ss->propagateArgsList);
ss->resampCriterionFunc = getListElement(opts, "resampCriterionFunc");
ss->resampCriterionArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2));
ss->nProtected += args_list2_init(ss->resampCriterionArgsList);
ss->resampFunc = getListElement(opts, "resampFunc");
ss->resampArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2));
ss->nProtected += args_list2_init(ss->resampArgsList);
ss->summaryFunc = getListElement(opts, "summaryFunc");
ss->summaryArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2));
ss->nProtected += args_list2_init(ss->summaryArgsList);
ss->MHUpdateFunc = getListElement(opts, "MHUpdateFunc");
ss->MHUpdateArgsList = (ArgsList3 *) R_alloc(1, sizeof(struct ArgsList3));
ss->nProtected += args_list3_init(ss->MHUpdateArgsList);
SEXPTmp = getListElement(opts, "doCallFunc");
PROTECT(ss->doCallFuncCall = lang4(SEXPTmp, R_NilValue,
R_NilValue, R_NilValue));
++(ss->nProtected);
ss->doCallFuncEnv = getListElement(opts, "doCallFuncEnv");
SEXPTmp = getListElement(opts, "procTimeFunc");
PROTECT(ss->procTimeFuncCall = lang1(SEXPTmp));
++(ss->nProtected);
ss->procTimeFuncEnv = getListElement(opts, "procTimeFuncEnv");
ss->timeDetails = (TimeDetails *) R_alloc(1, sizeof(struct TimeDetails));
PROTECT(ss->SEXPCurrentPeriod = allocVector(INTSXP, 1)); ++(ss->nProtected);
PROTECT(ss->SEXPNStreamsToGenerate = allocVector(INTSXP, 1)); ++(ss->nProtected);
PROTECT(ss->SEXPNMHSteps = allocVector(INTSXP, 1)); ++(ss->nProtected);
ss->dotsList = getListElement(opts, "dotsList");
ss->SEXPCurrentStreams = R_NilValue;
PROTECT(ss->SEXPLag1Streams = allocMatrix(REALSXP, ss->nStreams, ss->dimPerPeriod));
++(ss->nProtected);
ss->SEXPCurrentLogWeights = R_NilValue;
PROTECT(ss->SEXPCurrentAdjWeights = allocVector(REALSXP, ss->nStreamsPreResamp));
++(ss->nProtected);
PROTECT(ss->SEXPLag1LogWeights = allocVector(REALSXP, ss->nStreams));
++(ss->nProtected);
PROTECT(ss->SEXPLag1AdjWeights = allocVector(REALSXP, ss->nStreams));
++(ss->nProtected);
PROTECT(ss->SEXPAcceptanceRates = allocVector(REALSXP, ss->nStreams));
++(ss->nProtected);
PROTECT(ss->SEXPSummary = allocVector(REALSXP, ss->dimSummPerPeriod));
++(ss->nProtected);
PROTECT(ss->SEXPPropUniqueStreamIds = allocVector(REALSXP, 1));
++(ss->nProtected);
ss->scratch_RC = (ResampleContext *) R_alloc(1, sizeof(struct ResampleContext));
ss->scratch_RC->streamIds = (int *) R_alloc(ss->nStreams, sizeof(int));
ss->scratch_RC->uniqueStreamIds = (int *) R_alloc(ss->nStreams, sizeof(int));
ss->scratch_RC->partialSum = (double *) R_alloc(ss->nStreamsPreResamp, sizeof(double));
return ss;
}
static int nvimcom_checklibs()
{
const char *libname;
char buf[256];
char *libn;
SEXP a, l;
PROTECT(a = eval(lang1(install("search")), R_GlobalEnv));
int newnlibs = Rf_length(a);
if(nlibs == newnlibs)
return(nlibs);
int k = 0;
for(int i = 0; i < newnlibs; i++){
if(i == 62)
break;
PROTECT(l = STRING_ELT(a, i));
libname = CHAR(l);
libn = strstr(libname, "package:");
if(libn != NULL){
strncpy(loadedlibs[k], libname, 63);
loadedlibs[k+1][0] = 0;
#ifdef WIN32
if(tcltkerr == 0){
if(strstr(libn, "tcltk") != NULL){
REprintf("Error: \"nvimcom\" and \"tcltk\" packages are incompatible!\n");
tcltkerr = 1;
}
}
#endif
k++;
}
UNPROTECT(1);
}
UNPROTECT(1);
for(int i = 0; i < 64; i++){
if(loadedlibs[i][0] == 0)
break;
for(int j = 0; j < 64; j++){
libn = strstr(loadedlibs[i], ":");
libn++;
if(strcmp(builtlibs[j], libn) == 0)
break;
if(builtlibs[j][0] == 0){
strcpy(builtlibs[j], libn);
sprintf(buf, "nvimcom:::nvim.buildomnils('%s')", libn);
nvimcom_eval_expr(buf);
needsfillmsg = 1;
break;
}
}
}
char fn[512];
snprintf(fn, 510, "%s/libnames_%s", tmpdir, getenv("NVIMR_ID"));
FILE *f = fopen(fn, "w");
if(f == NULL){
REprintf("Error: Could not write to '%s'. [nvimcom]\n", fn);
return(newnlibs);
}
for(int i = 0; i < 64; i++){
if(builtlibs[i][0] == 0)
break;
fprintf(f, "%s\n", builtlibs[i]);
}
fclose(f);
return(newnlibs);
}
void setup_Rmainloop(void)
{
volatile int doneit;
volatile SEXP baseEnv;
SEXP cmd;
char deferred_warnings[11][250];
volatile int ndeferred_warnings = 0;
/* In case this is a silly limit: 2^32 -3 has been seen and
* casting to intptr_r relies on this being smaller than 2^31 on a
* 32-bit platform. */
if(R_CStackLimit > 100000000U)
R_CStackLimit = (uintptr_t)-1;
/* make sure we have enough head room to handle errors */
if(R_CStackLimit != -1)
R_CStackLimit = (uintptr_t)(0.95 * R_CStackLimit);
InitConnections(); /* needed to get any output at all */
/* Initialize the interpreter's internal structures. */
#ifdef HAVE_LOCALE_H
#ifdef Win32
{
char *p, Rlocale[1000]; /* Windows' locales can be very long */
p = getenv("LC_ALL");
strncpy(Rlocale, p ? p : "", 1000);
Rlocale[1000 - 1] = '\0';
if(!(p = getenv("LC_CTYPE"))) p = Rlocale;
/* We'd like to use warning, but need to defer.
Also cannot translate. */
if(!setlocale(LC_CTYPE, p))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_CTYPE=%s failed\n", p);
if((p = getenv("LC_COLLATE"))) {
if(!setlocale(LC_COLLATE, p))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_COLLATE=%s failed\n", p);
} else setlocale(LC_COLLATE, Rlocale);
if((p = getenv("LC_TIME"))) {
if(!setlocale(LC_TIME, p))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_TIME=%s failed\n", p);
} else setlocale(LC_TIME, Rlocale);
if((p = getenv("LC_MONETARY"))) {
if(!setlocale(LC_MONETARY, p))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MONETARY=%s failed\n", p);
} else setlocale(LC_MONETARY, Rlocale);
/* Windows does not have LC_MESSAGES */
/* We set R_ARCH here: Unix does it in the shell front-end */
char Rarch[30];
strcpy(Rarch, "R_ARCH=/");
strcat(Rarch, R_ARCH);
putenv(Rarch);
}
#else /* not Win32 */
if(!setlocale(LC_CTYPE, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_CTYPE failed, using \"C\"\n");
if(!setlocale(LC_COLLATE, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_COLLATE failed, using \"C\"\n");
if(!setlocale(LC_TIME, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_TIME failed, using \"C\"\n");
#ifdef ENABLE_NLS
if(!setlocale(LC_MESSAGES, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MESSAGES failed, using \"C\"\n");
#endif
/* NB: we do not set LC_NUMERIC */
#ifdef LC_MONETARY
if(!setlocale(LC_MONETARY, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MONETARY failed, using \"C\"\n");
#endif
#ifdef LC_PAPER
if(!setlocale(LC_PAPER, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_PAPER failed, using \"C\"\n");
#endif
#ifdef LC_MEASUREMENT
if(!setlocale(LC_MEASUREMENT, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MEASUREMENT failed, using \"C\"\n");
#endif
#endif /* not Win32 */
#endif
/* make sure srand is called before R_tmpnam, PR#14381 */
srand(TimeToSeed());
InitArithmetic();
InitParser();
InitTempDir(); /* must be before InitEd */
InitMemory();
InitStringHash(); /* must be before InitNames */
InitNames();
InitBaseEnv();
InitGlobalEnv();
InitDynload();
InitOptions();
InitEd();
InitGraphics();
InitTypeTables(); /* must be before InitS3DefaultTypes */
InitS3DefaultTypes();
R_Is_Running = 1;
R_check_locale();
/* Initialize the global context for error handling. */
/* This provides a target for any non-local gotos */
/* which occur during error handling */
R_Toplevel.nextcontext = NULL;
R_Toplevel.callflag = CTXT_TOPLEVEL;
R_Toplevel.cstacktop = 0;
R_Toplevel.promargs = R_NilValue;
R_Toplevel.callfun = R_NilValue;
R_Toplevel.call = R_NilValue;
R_Toplevel.cloenv = R_BaseEnv;
R_Toplevel.sysparent = R_BaseEnv;
R_Toplevel.conexit = R_NilValue;
R_Toplevel.vmax = NULL;
R_Toplevel.nodestack = R_BCNodeStackTop;
#ifdef BC_INT_STACK
R_Toplevel.intstack = R_BCIntStackTop;
#endif
R_Toplevel.cend = NULL;
R_Toplevel.intsusp = FALSE;
R_Toplevel.handlerstack = R_HandlerStack;
R_Toplevel.restartstack = R_RestartStack;
R_Toplevel.srcref = R_NilValue;
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
R_ExitContext = NULL;
R_Warnings = R_NilValue;
/* This is the same as R_BaseEnv, but this marks the environment
of functions as the namespace and not the package. */
baseEnv = R_BaseNamespace;
/* Set up some global variables */
Init_R_Variables(baseEnv);
/* On initial entry we open the base language package and begin by
running the repl on it.
If there is an error we pass on to the repl.
Perhaps it makes more sense to quit gracefully?
*/
#ifdef RMIN_ONLY
/* This is intended to support a minimal build for experimentation. */
if (R_SignalHandlers) init_signal_handlers();
#else
FILE *fp = R_OpenLibraryFile("base");
if (fp == NULL)
R_Suicide(_("unable to open the base package\n"));
doneit = 0;
SETJMP(R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (R_SignalHandlers) init_signal_handlers();
if (!doneit) {
doneit = 1;
R_ReplFile(fp, baseEnv);
}
fclose(fp);
#endif
/* This is where we source the system-wide, the site's and the
user's profile (in that order). If there is an error, we
drop through to further processing.
*/
R_IoBufferInit(&R_ConsoleIob);
R_LoadProfile(R_OpenSysInitFile(), baseEnv);
/* These are the same bindings, so only lock them once */
R_LockEnvironment(R_BaseNamespace, TRUE);
#ifdef NOTYET
/* methods package needs to trample here */
R_LockEnvironment(R_BaseEnv, TRUE);
#endif
/* At least temporarily unlock some bindings used in graphics */
R_unLockBinding(R_DeviceSymbol, R_BaseEnv);
R_unLockBinding(R_DevicesSymbol, R_BaseEnv);
R_unLockBinding(install(".Library.site"), R_BaseEnv);
/* require(methods) if it is in the default packages */
doneit = 0;
SETJMP(R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (!doneit) {
doneit = 1;
PROTECT(cmd = install(".OptRequireMethods"));
R_CurrentExpr = findVar(cmd, R_GlobalEnv);
if (R_CurrentExpr != R_UnboundValue &&
TYPEOF(R_CurrentExpr) == CLOSXP) {
PROTECT(R_CurrentExpr = lang1(cmd));
R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
UNPROTECT(1);
}
UNPROTECT(1);
}
if (strcmp(R_GUIType, "Tk") == 0) {
char buf[PATH_MAX];
snprintf(buf, PATH_MAX, "%s/library/tcltk/exec/Tk-frontend.R", R_Home);
R_LoadProfile(R_fopen(buf, "r"), R_GlobalEnv);
}
/* Print a platform and version dependent greeting and a pointer to
* the copyleft.
*/
if(!R_Quiet) PrintGreeting();
R_LoadProfile(R_OpenSiteFile(), baseEnv);
R_LockBinding(install(".Library.site"), R_BaseEnv);
R_LoadProfile(R_OpenInitFile(), R_GlobalEnv);
/* This is where we try to load a user's saved data.
The right thing to do here is very platform dependent.
E.g. under Unix we look in a special hidden file and on the Mac
we look in any documents which might have been double clicked on
or dropped on the application.
*/
doneit = 0;
SETJMP(R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (!doneit) {
doneit = 1;
R_InitialData();
}
else {
if (! SETJMP(R_Toplevel.cjmpbuf)) {
warning(_("unable to restore saved data in %s\n"), get_workspace_name());
}
}
/* Initial Loading is done.
At this point we try to invoke the .First Function.
If there is an error we continue. */
doneit = 0;
SETJMP(R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (!doneit) {
doneit = 1;
PROTECT(cmd = install(".First"));
R_CurrentExpr = findVar(cmd, R_GlobalEnv);
if (R_CurrentExpr != R_UnboundValue &&
TYPEOF(R_CurrentExpr) == CLOSXP) {
PROTECT(R_CurrentExpr = lang1(cmd));
R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
UNPROTECT(1);
}
UNPROTECT(1);
}
/* Try to invoke the .First.sys function, which loads the default packages.
If there is an error we continue. */
doneit = 0;
SETJMP(R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (!doneit) {
doneit = 1;
PROTECT(cmd = install(".First.sys"));
R_CurrentExpr = findVar(cmd, baseEnv);
if (R_CurrentExpr != R_UnboundValue &&
TYPEOF(R_CurrentExpr) == CLOSXP) {
PROTECT(R_CurrentExpr = lang1(cmd));
R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
UNPROTECT(1);
}
UNPROTECT(1);
}
{
int i;
for(i = 0 ; i < ndeferred_warnings; i++)
warning(deferred_warnings[i]);
}
if (R_CollectWarnings) {
REprintf(_("During startup - "));
PrintWarnings();
}
/* trying to do this earlier seems to run into bootstrapping issues. */
R_init_jit_enabled();
R_Is_Running = 2;
}
static void userControlEnd(void *userData)
{
SEXP fn = (SEXP)userData;
eval(lang1(fn), R_GlobalEnv);
}
SEXP port_nlsb(SEXP m, SEXP d, SEXP gg, SEXP iv, SEXP v,
SEXP lowerb, SEXP upperb)
{
int *dims = INTEGER(getAttrib(gg, R_DimSymbol));
int i, n = LENGTH(d), p = LENGTH(d), nd = dims[0];
SEXP getPars, setPars, resid, gradient,
rr = PROTECT(allocVector(REALSXP, nd)),
x = PROTECT(allocVector(REALSXP, n));
// This used to use Calloc, but that will leak if
// there is a premature return (and did in package drfit)
double *b = (double *) NULL,
*rd = (double *)R_alloc(nd, sizeof(double));
if (!isReal(d) || n < 1)
error(_("'d' must be a nonempty numeric vector"));
if(!isNewList(m)) error(_("m must be a list"));
/* Initialize parameter vector */
getPars = PROTECT(lang1(getFunc(m, "getPars", "m")));
eval_check_store(getPars, R_GlobalEnv, x);
/* Create the setPars call */
setPars = PROTECT(lang2(getFunc(m, "setPars", "m"), x));
/* Evaluate residual and gradient */
resid = PROTECT(lang1(getFunc(m, "resid", "m")));
eval_check_store(resid, R_GlobalEnv, rr);
gradient = PROTECT(lang1(getFunc(m, "gradient", "m")));
neggrad(gradient, R_GlobalEnv, gg);
if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) {
if (isReal(lowerb) && isReal(upperb)) {
double *rl = REAL(lowerb), *ru = REAL(upperb);
b = (double *)R_alloc(2*n, sizeof(double));
for (i = 0; i < n; i++) {
b[2*i] = rl[i];
b[2*i + 1] = ru[i];
}
} else error(_("'lowerb' and 'upperb' must be numeric vectors"));
}
do {
nlsb_iterate(b, REAL(d), REAL(gg), INTEGER(iv), LENGTH(iv),
LENGTH(v), n, nd, p, REAL(rr), rd,
REAL(v), REAL(x));
switch(INTEGER(iv)[0]) {
case -3:
eval(setPars, R_GlobalEnv);
eval_check_store(resid, R_GlobalEnv, rr);
neggrad(gradient, R_GlobalEnv, gg);
break;
case -2:
eval_check_store(resid, R_GlobalEnv, rr);
neggrad(gradient, R_GlobalEnv, gg);
break;
case -1:
eval(setPars, R_GlobalEnv);
eval_check_store(resid, R_GlobalEnv, rr);
neggrad(gradient, R_GlobalEnv, gg);
break;
case 0:
Rprintf("nlsb_iterate returned %d", INTEGER(iv)[0]);
break;
case 1:
eval(setPars, R_GlobalEnv);
eval_check_store(resid, R_GlobalEnv, rr);
break;
case 2:
eval(setPars, R_GlobalEnv);
neggrad(gradient, R_GlobalEnv, gg);
break;
}
} while(INTEGER(iv)[0] < 3);
UNPROTECT(6);
return R_NilValue;
}
/*
* call to nls_iter from R --- .Call("nls_iter", m, control, doTrace)
* where m and control are nlsModel and nlsControl objects
* doTrace is a logical value.
* m is modified; the return value is a "convergence-information" list.
*/
SEXP
nls_iter(SEXP m, SEXP control, SEXP doTraceArg)
{
double dev, fac, minFac, tolerance, newDev, convNew = -1./*-Wall*/;
int i, j, maxIter, hasConverged, nPars, doTrace, evaltotCnt = -1, warnOnly, printEval;
SEXP tmp, conv, incr, deviance, setPars, getPars, pars, newPars, trace;
doTrace = asLogical(doTraceArg);
if(!isNewList(control))
error(_("'control' must be a list"));
if(!isNewList(m))
error(_("'m' must be a list"));
PROTECT(tmp = getAttrib(control, R_NamesSymbol));
conv = getListElement(control, tmp, "maxiter");
if(conv == NULL || !isNumeric(conv))
error(_("'%s' absent"), "control$maxiter");
maxIter = asInteger(conv);
conv = getListElement(control, tmp, "tol");
if(conv == NULL || !isNumeric(conv))
error(_("'%s' absent"), "control$tol");
tolerance = asReal(conv);
conv = getListElement(control, tmp, "minFactor");
if(conv == NULL || !isNumeric(conv))
error(_("'%s' absent"), "control$minFactor");
minFac = asReal(conv);
conv = getListElement(control, tmp, "warnOnly");
if(conv == NULL || !isLogical(conv))
error(_("'%s' absent"), "control$warnOnly");
warnOnly = asLogical(conv);
conv = getListElement(control, tmp, "printEval");
if(conv == NULL || !isLogical(conv))
error(_("'%s' absent"), "control$printEval");
printEval = asLogical(conv);
#define CONV_INFO_MSG(_STR_, _I_) \
ConvInfoMsg(_STR_, i, _I_, fac, minFac, maxIter, convNew)
#define NON_CONV_FINIS(_ID_, _MSG_) \
if(warnOnly) { \
warning(_MSG_); \
return CONV_INFO_MSG(_MSG_, _ID_); \
} \
else \
error(_MSG_);
#define NON_CONV_FINIS_1(_ID_, _MSG_, _A1_) \
if(warnOnly) { \
char msgbuf[1000]; \
warning(_MSG_, _A1_); \
snprintf(msgbuf, 1000, _MSG_, _A1_); \
return CONV_INFO_MSG(msgbuf, _ID_); \
} \
else \
error(_MSG_, _A1_);
#define NON_CONV_FINIS_2(_ID_, _MSG_, _A1_, _A2_) \
if(warnOnly) { \
char msgbuf[1000]; \
warning(_MSG_, _A1_, _A2_); \
snprintf(msgbuf, 1000, _MSG_, _A1_, _A2_); \
return CONV_INFO_MSG(msgbuf, _ID_); \
} \
else \
error(_MSG_, _A1_, _A2_);
/* now get parts from 'm' */
tmp = getAttrib(m, R_NamesSymbol);
conv = getListElement(m, tmp, "conv");
if(conv == NULL || !isFunction(conv))
error(_("'%s' absent"), "m$conv()");
PROTECT(conv = lang1(conv));
incr = getListElement(m, tmp, "incr");
if(incr == NULL || !isFunction(incr))
error(_("'%s' absent"), "m$incr()");
PROTECT(incr = lang1(incr));
deviance = getListElement(m, tmp, "deviance");
if(deviance == NULL || !isFunction(deviance))
error(_("'%s' absent"), "m$deviance()");
PROTECT(deviance = lang1(deviance));
trace = getListElement(m, tmp, "trace");
if(trace == NULL || !isFunction(trace))
error(_("'%s' absent"), "m$trace()");
PROTECT(trace = lang1(trace));
setPars = getListElement(m, tmp, "setPars");
if(setPars == NULL || !isFunction(setPars))
error(_("'%s' absent"), "m$setPars()");
PROTECT(setPars);
getPars = getListElement(m, tmp, "getPars");
if(getPars == NULL || !isFunction(getPars))
error(_("'%s' absent"), "m$getPars()");
PROTECT(getPars = lang1(getPars));
PROTECT(pars = eval(getPars, R_GlobalEnv));
nPars = LENGTH(pars);
dev = asReal(eval(deviance, R_GlobalEnv));
if(doTrace) eval(trace,R_GlobalEnv);
fac = 1.0;
hasConverged = FALSE;
PROTECT(newPars = allocVector(REALSXP, nPars));
if(printEval)
evaltotCnt = 1;
for (i = 0; i < maxIter; i++) {
SEXP newIncr;
int evalCnt = -1;
if((convNew = asReal(eval(conv, R_GlobalEnv))) < tolerance) {
hasConverged = TRUE;
break;
}
PROTECT(newIncr = eval(incr, R_GlobalEnv));
if(printEval)
evalCnt = 1;
while(fac >= minFac) {
if(printEval) {
Rprintf(" It. %3d, fac= %11.6g, eval (no.,total): (%2d,%3d):",
i+1, fac, evalCnt, evaltotCnt);
evalCnt++;
evaltotCnt++;
}
for(j = 0; j < nPars; j++)
REAL(newPars)[j] = REAL(pars)[j] + fac * REAL(newIncr)[j];
PROTECT(tmp = lang2(setPars, newPars));
if (asLogical(eval(tmp, R_GlobalEnv))) { /* singular gradient */
UNPROTECT(11);
NON_CONV_FINIS(1, _("singular gradient"));
}
UNPROTECT(1);
newDev = asReal(eval(deviance, R_GlobalEnv));
if(printEval)
Rprintf(" new dev = %g\n", newDev);
if(newDev <= dev) {
dev = newDev;
fac = MIN(2*fac, 1);
tmp = newPars;
newPars = pars;
pars = tmp;
break;
}
fac /= 2.;
}
UNPROTECT(1);
if( fac < minFac ) {
UNPROTECT(9);
NON_CONV_FINIS_2(2,
_("step factor %g reduced below 'minFactor' of %g"),
fac, minFac);
}
if(doTrace) eval(trace, R_GlobalEnv);
}
UNPROTECT(9);
if(!hasConverged) {
NON_CONV_FINIS_1(3,
_("number of iterations exceeded maximum of %d"),
maxIter);
}
/* else */
return CONV_INFO_MSG(_("converged"), 0);
}
SEXP gridCallback(GEevent task, pGEDevDesc dd, SEXP data) {
SEXP result = R_NilValue;
SEXP valid, scale;
SEXP gridState;
GESystemDesc *sd;
SEXP currentgp;
SEXP gsd;
SEXP devsize;
R_GE_gcontext gc;
switch (task) {
case GE_InitState:
/* Create the initial grid state for a device
*/
PROTECT(gridState = createGridSystemState());
/* Store that state with the device for easy retrieval
*/
sd = dd->gesd[gridRegisterIndex];
sd->systemSpecific = (void*) gridState;
/* Initialise the grid state for a device
*/
fillGridSystemState(gridState, dd);
/* Also store the state beneath a top-level variable so
* that it does not get garbage-collected
*/
globaliseState(gridState);
/* Indicate success */
result = R_BlankString;
UNPROTECT(1);
break;
case GE_FinaliseState:
sd = dd->gesd[gridRegisterIndex];
/* Simply detach the system state from the global variable
* and it will be garbage-collected
*/
deglobaliseState((SEXP) sd->systemSpecific);
/* Also set the device pointer to NULL
*/
sd->systemSpecific = NULL;
break;
case GE_SaveState:
break;
case GE_RestoreState:
gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
PROTECT(devsize = allocVector(REALSXP, 2));
getDeviceSize(dd, &(REAL(devsize)[0]), &(REAL(devsize)[1]));
SET_VECTOR_ELT(gsd, GSS_DEVSIZE, devsize);
UNPROTECT(1);
/* Only bother to do any grid drawing setup
* if there has been grid output
* on this device.
*/
if (LOGICAL(gridStateElement(dd, GSS_GRIDDEVICE))[0]) {
if (LOGICAL(gridStateElement(dd, GSS_ENGINEDLON))[0]) {
/* The graphics engine is about to replay the display list
* So we "clear" the device and reset the grid graphics state
*/
/* There are two main situations in which this occurs:
* (i) a screen is resized
* In this case, it is ok-ish to do a GENewPage
* because that has the desired effect and no
* undesirable effects because it only happens on
* a screen device -- a new page is the same as
* clearing the screen
* (ii) output on one device is copied to another device
* In this case, a GENewPage is NOT a good thing, however,
* here we will start with a new device and it will not
* have any grid output so this section will not get called
* SO we will not get any unwanted blank pages.
*
* All this is a bit fragile; ultimately, what would be ideal
* is a dev->clearPage primitive for all devices in addition
* to the dev->newPage primitive
*/
currentgp = gridStateElement(dd, GSS_GPAR);
gcontextFromgpar(currentgp, 0, &gc, dd);
GENewPage(&gc, dd);
initGPar(dd);
initVP(dd);
initOtherState(dd);
} else {
/*
* If we have turned off the graphics engine's display list
* then we have to redraw the scene ourselves
*/
SEXP fcall;
PROTECT(fcall = lang1(install("draw.all")));
eval(fcall, R_gridEvalEnv);
UNPROTECT(1);
}
}
break;
case GE_CopyState:
break;
case GE_CheckPlot:
PROTECT(valid = allocVector(LGLSXP, 1));
LOGICAL(valid)[0] = TRUE;
UNPROTECT(1);
result = valid;
case GE_SaveSnapshotState:
break;
case GE_RestoreSnapshotState:
break;
case GE_ScalePS:
/*
* data is a numeric scale factor
*/
PROTECT(scale = allocVector(REALSXP, 1));
REAL(scale)[0] = REAL(gridStateElement(dd, GSS_SCALE))[0]*
REAL(data)[0];
setGridStateElement(dd, GSS_SCALE, scale);
UNPROTECT(1);
break;
}
return result;
}
SEXP PartitionedLeaping(SEXP pre, SEXP post, SEXP h, SEXP M, SEXP T, SEXP delta,
SEXP runs, SEXP place, SEXP transition, SEXP ect, SEXP rho)
{
int k;
double dTmp;
#ifdef RB_TIME
clock_t c0, c1;
c0 = clock();
#endif
// Get dimensions of pre
int *piTmp = INTEGER(getAttrib(pre, R_DimSymbol));
int iTransitions = piTmp[0], iPlaces = piTmp[1];
int *piPre = INTEGER(pre), *piPost = INTEGER(post);
SEXP sexpTmp;
int iTransition, iPlace, iTransitionPtr, iPlacePtr,
iTransition2, iPlace2, iTransitionPtr2, iPlacePtr2;
// Find out which elements of h are doubles and which functions
SEXP sexpFunction;
PROTECT(sexpFunction = allocVector(VECSXP, iTransitions));
double *pdH = (double *) R_alloc(iTransitions, sizeof(double));
DL_FUNC *pCFunction = (DL_FUNC *) R_alloc(iTransitions, sizeof(DL_FUNC *));
int *piHzType = (int *) R_alloc(iTransitions, sizeof(int));
for (iTransition = 0; iTransition < iTransitions; iTransition++) {
if (inherits(sexpTmp = VECTOR_ELT(h, iTransition), "NativeSymbol")) {
pCFunction[iTransition] = (void *) R_ExternalPtrAddr(sexpTmp);
piHzType[iTransition] = HZ_CFUNCTION;
} else if (isNumeric(sexpTmp)){
pdH[iTransition] = REAL(sexpTmp)[0];
piHzType[iTransition] = HZ_DOUBLE;
} else if (isFunction(sexpTmp)) {
SET_VECTOR_ELT(sexpFunction, iTransition, lang1(sexpTmp));
piHzType[iTransition] = HZ_RFUNCTION;
} else {
error("Unrecongnized transition function type\n");
}
}
// Setup Matrix S
int *piS = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
int *piSSATransition = (int *) R_alloc(iTransitions, sizeof(int));
int *piTauLeapTransition = (int *) R_alloc(iTransitions, sizeof(int));
int *piCLETransition = (int *) R_alloc(iTransitions, sizeof(int));
int *piDetermTransition = (int *) R_alloc(iTransitions, sizeof(int));
int iSSATransitions, iTauLeapTransitions, iCLETransitions, iDetermTransitions;
int *piSlowTransition = (int *) R_alloc(iTransitions, sizeof(int));
int *piFastTransition = (int *) R_alloc(iTransitions, sizeof(int));
int iSlowTransitions = 0, iFastTransitions = 0;
// Position of non zero cells in pre per transition
int *piPreNZxRow = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Totals of non zero cells in pre per transition
int *piPreNZxRowTot = (int *) R_alloc(iTransitions, sizeof(int));
// Position of non zero cells in S per transition
int *piSNZxRow = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Totals of non zero cells in S per transition
int *piSNZxRowTot = (int *) R_alloc(iTransitions, sizeof(int));
int *piOrderedTransition = (int *) R_alloc(iTransitions, sizeof(int *));
for (iTransition = 0; iTransition < iTransitions; iTransition++) {
int iPreNZxRow_col = 0;
int iSNZxRow_col = 0;
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
if (piPre[iTransition + iTransitions * iPlace]) {
piPreNZxRow[iTransition + iTransitions * iPreNZxRow_col++] = iPlace;
}
if ((piS[iTransition + iTransitions * iPlace] =
piPost[iTransition + iTransitions * iPlace] - piPre[iTransition + iTransitions * iPlace])) {
piSNZxRow[iTransition + iTransitions * iSNZxRow_col++] = iPlace;
}
}
piPreNZxRowTot[iTransition] = iPreNZxRow_col;
piSNZxRowTot[iTransition] = iSNZxRow_col;
}
int *piSNZxCol = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
int *piSNZxColTot = (int *) R_alloc(iPlaces, sizeof(int));
int *piPreNZxCol = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
int *piPreNZxColTot = (int *) R_alloc(iTransitions, sizeof(int));
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
int iSNZxCol_row = 0;
int iPreNZxCol_row = 0;
for (iTransition = 0; iTransition < iTransitions; iTransition++) {
if(piS[iTransition + iTransitions * iPlace]) {
piSNZxCol[iSNZxCol_row++ + iTransitions * iPlace] = iTransition;
}
if(piPre[iTransition + iTransitions * iPlace]) {
piPreNZxCol[iPreNZxCol_row++ + iTransitions * iPlace] = iTransition;
}
}
piSNZxColTot[iPlace] = iSNZxCol_row;
piPreNZxColTot[iPlace] = iPreNZxCol_row;
}
double *pdG = (double *) R_alloc(iPlaces, sizeof(double));
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
int iHOR = 0;
pdG[iPlace] = 0;
for(iTransitionPtr = 0; iTransitionPtr < piPreNZxColTot[iPlace]; iTransitionPtr++) {
iTransition = piPreNZxCol[iTransitionPtr + iTransitions * iPlace];
int iThisHOR = 0, iThisHORPlace = 0;
for(iPlacePtr2 = 0; iPlacePtr2 < piPreNZxRowTot[iTransition]; iPlacePtr2++) {
iPlace2 = piPreNZxRow[iTransition + iTransitions * iPlacePtr2];
iThisHOR += piPre[iTransition + iTransitions * iPlace2];
if (iPlace2 == iPlace)
iThisHORPlace = piPre[iTransition + iTransitions * iPlace2];
}
if (iThisHOR >= iHOR) {
double dThisG = 0;
switch (iThisHOR) {
case 0:
// dThisG = 0;
break;
case 1:
dThisG = 1;
break;
case 2:
if (iThisHORPlace == 1)
dThisG = 2;
else if (iThisHORPlace == 2)
dThisG = 3;
else
error("G: case not considered\n");
break;
case 3:
if (iThisHORPlace == 1)
dThisG = 3;
else if (iThisHORPlace == 2)
dThisG = 9./2.;
else if (iThisHORPlace == 3)
dThisG = 11./2.;
else
error("G: case not considered\n");
break;
default:
error("G: case not considered\n");
}
iHOR = iThisHOR;
if (dThisG > pdG[iPlace])
pdG[iPlace] = dThisG;
}
}
}
int *piSlowPlace = (int *) R_alloc(iPlaces, sizeof(int));
int *piFastPlace = (int *) R_alloc(iPlaces, sizeof(int));
int iSlowPlaces = 0, iFastPlaces = 0;
// Position of non zero cells in S per place
int *piFastSNZxCol = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Totals of non zero cells in S per place
int *piFastSNZxColTot = (int *) R_alloc(iPlaces, sizeof(int));
// Position of non zero cells in pre per transition
int *piSlowPreNZxCol = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));
// Totals of non zero cells in pre per transition
int *piSlowPreNZxColTot = (int *) R_alloc(iTransitions, sizeof(int));
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
int iFastSNZxCol_row = 0;
int iFastPlace = FALSE;
for (iTransitionPtr = 0; iTransitionPtr < iFastTransitions; iTransitionPtr++) {
iTransition = piFastTransition[iTransitionPtr];
if(piS[iTransition + iTransitions * iPlace]) {
iFastPlace = TRUE;
piFastSNZxCol[iFastSNZxCol_row++ + iTransitions * iPlace] = iTransition;
}
}
piFastSNZxColTot[iPlace] = iFastSNZxCol_row;
if (iFastPlace)
piFastPlace[iFastPlaces++] = iPlace;
int iSlowPreNZxCol_row = 0;
int iSlowPlace = FALSE;
for (iTransitionPtr = 0; iTransitionPtr < iSlowTransitions; iTransitionPtr++) {
iTransition = piSlowTransition[iTransitionPtr];
if(piPre[iTransition + iTransitions * iPlace]) {
iSlowPlace = TRUE;
piSlowPreNZxCol[iSlowPreNZxCol_row++ + iTransitions * iPlace] = iTransition;
}
}
piSlowPreNZxColTot[iPlace] = iSlowPreNZxCol_row;
if (iSlowPlace)
piSlowPlace[iSlowPlaces++] = iPlace;
}
// Hazards that need to be recalculated if a given transition has happened
int *piHazardsToModxRow = (int *) R_alloc((iTransitions + 2) * iTransitions, sizeof(int));
// Totals of hazards to recalculate for each transition that has happened
int *piHazardsToModxRowTot = (int *) R_alloc(iTransitions + 2, sizeof(int));
piHazardsToModxRowTot[iTransitions + 1] = 0;
for (iTransitionPtr = 0; iTransitionPtr < iSlowTransitions; iTransitionPtr++) {
iTransition = piSlowTransition[iTransitionPtr];
int iSlowTransitionHazardUpdatedByFastPlace = FALSE;
int iHazardToCompTot = 0;
for(iPlace = 0; iPlace < iPlaces; iPlace++) {
if (piS[iTransition + iTransitions * iPlace]) {
// Identify the transitions that need the hazards recalculated
for(iTransitionPtr2 = 0; iTransitionPtr2 < piSlowPreNZxColTot[iPlace]; iTransitionPtr2++) {
iTransition2 = piSlowPreNZxCol[iTransitionPtr2 + iTransitions * iPlace];
int iAddThis = TRUE;
for (k = 0; k < iHazardToCompTot; k++) {
if(piHazardsToModxRow[iTransition + (iTransitions + 2) * k] == iTransition2) {
iAddThis = FALSE;
break;
}
}
if (iAddThis)
piHazardsToModxRow[iTransition + (iTransitions + 2) * iHazardToCompTot++] = iTransition2;
}
}
// Which slow transitions hazard have to be recalculated after updating the fast places.
if (!iSlowTransitionHazardUpdatedByFastPlace && piPre[iTransition + iTransitions * iPlace]) {
for(iPlacePtr2 = 0; iPlacePtr2 < iFastPlaces; iPlacePtr2++) {
iPlace2 = piFastPlace[iPlacePtr2];
if (iPlace2 == iPlace) {
iSlowTransitionHazardUpdatedByFastPlace = TRUE;
piHazardsToModxRow[iTransitions + 1 +
(iTransitions + 2) * piHazardsToModxRowTot[iTransitions + 1]++] = iTransition;
break;
}
}
}
}
piHazardsToModxRowTot[iTransition] = iHazardToCompTot;
}
// For the initial calculation of all hazards...
for(iTransitionPtr = 0; iTransitionPtr < iSlowTransitions; iTransitionPtr++) {
iTransition = piSlowTransition[iTransitionPtr];
piHazardsToModxRow[iTransitions + (iTransitions + 2) * iTransitionPtr] = iTransition;
}
piHazardsToModxRowTot[iTransitions] = iSlowTransitions;
SEXP sexpTmpCrntMarking;
PROTECT(sexpTmpCrntMarking = allocVector(REALSXP, iPlaces));
double *pdTmpCrntMarking = REAL(sexpTmpCrntMarking);
SEXP sexpCrntMarking;
PROTECT(sexpCrntMarking = allocVector(REALSXP, iPlaces));
double *pdCrntMarking = REAL(sexpCrntMarking);
double *pdBakCrntMarking = (double *) R_alloc(iPlaces, sizeof(double));
double dDelta = *REAL(delta);
int iTotalSteps, iSectionSteps;
double dT = 0;
void *pCManage_time = 0;
SEXP sexpRManage_time = 0;
if (inherits(T, "NativeSymbol")) {
pCManage_time = (void *) R_ExternalPtrAddr(T);
dT = ((double(*)(double, double *)) pCManage_time)(-1, pdCrntMarking);
} else if (isNumeric(T)){
dT = *REAL(T);
} else if (isFunction(T)) {
PROTECT(sexpRManage_time = lang1(T));
defineVar(install("y"), sexpCrntMarking, rho);
PROTECT(sexpTmp = allocVector(REALSXP, 1));
*REAL(sexpTmp) = -1;
defineVar(install("StartTime"), sexpTmp, rho);
UNPROTECT_PTR(sexpTmp);
dT = *REAL(VECTOR_ELT(eval(sexpRManage_time, rho),0));
} else {
error("Unrecognized time function type\n");
}
iTotalSteps = iSectionSteps = (int)(dT / dDelta) + 1;
int iRun, iRuns = *INTEGER(runs);
// Hazard vector
double *pdHazard = (double *) R_alloc(iTransitions, sizeof(double));
SEXP sexpRun;
PROTECT(sexpRun = allocVector(VECSXP, iRuns));
int iTotalUsedRandomNumbers = 0;
// DiscTime Vector
SEXP sexpD_time;
PROTECT(sexpD_time = allocVector(REALSXP, iTotalSteps));
double *pdDiscTime = REAL(sexpD_time);
dTmp = 0;
for (k = 0; k < iTotalSteps; k++) {
pdDiscTime[k] = dTmp;
dTmp += dDelta;
}
SEXP sexpMarkingRowNames;
PROTECT(sexpMarkingRowNames = allocVector(INTSXP, iTotalSteps));
piTmp = INTEGER(sexpMarkingRowNames);
for (k = 0; k < iTotalSteps; k++)
piTmp[k] = k+1;
double **ppdMarking = (double **) R_alloc(iPlaces, sizeof(double *));
#ifdef RB_SAVE_INCR_INFO
double *pdIncr = (double *) R_alloc(INCR_TO_SAVE, sizeof(double));
double *pdIncrTime = (double *) R_alloc(INCR_TO_SAVE, sizeof(double));
double *pdAcumHazard = (double *) R_alloc(INCR_TO_SAVE, sizeof(double));
double *pdIntHazard = (double *) R_alloc(INCR_TO_SAVE, sizeof(double));
double *pdIntHazardTime = (double *) R_alloc(INCR_TO_SAVE, sizeof(double));
#endif
double *pdSSARescaling = (double *) R_alloc(iTransitions, sizeof(double));
double *pdSSATau = (double *) R_alloc(iTransitions, sizeof(double));
double dEpsilon = 0.03;
double dApproxEqualOne = 3;
double dGreaterGreaterOne = 100;
GetRNGstate();
for (iRun = 0; iRun < iRuns; iRun++) {
#ifdef RB_SAVE_INCR_INFO
int iTotIntHazardTime = 0, iTotIncrTime = 0;
#endif
int iUsedRandomNumbers = 0;
Rprintf("%d ", iRun+1);
// Totals for kind of transition vector
SEXP sexpTotXTransition;
PROTECT(sexpTotXTransition = allocVector(INTSXP, iTransitions));
int *piTotTransitions = INTEGER(sexpTotXTransition);
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
piTotTransitions[iTransition] = 0;
pdSSARescaling[iTransition] = -1;
}
for(iTransitionPtr = 0; iTransitionPtr < iSlowTransitions; iTransitionPtr++) {
piOrderedTransition[iTransitionPtr] = piSlowTransition[iTransitionPtr];
}
SEXP sexpMarking;
PROTECT(sexpMarking = allocVector(VECSXP, iPlaces));
//setAttrib(sexpMarking, R_NamesSymbol, place);
//setAttrib(sexpMarking, R_RowNamesSymbol, sexpMarkingRowNames);
//setAttrib(sexpMarking, R_ClassSymbol, ScalarString(mkChar("data.frame")));
// Setup initial state
double *pdTmp = REAL(M);
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
SET_VECTOR_ELT(sexpMarking, iPlace, sexpTmp = allocVector(REALSXP, iTotalSteps));
ppdMarking[iPlace] = REAL(sexpTmp);
pdCrntMarking[iPlace] = pdBakCrntMarking[iPlace] = pdTmp[iPlace];
}
double dTime, dTarget = 0;
int iTotTransitions = 0;
int iStep = 0;
int iInterruptCnt = 10000000;
double dNewHazard = 0;
do {
if (iStep) {
--iStep;
for(iPlace = 0; iPlace < iPlaces; iPlace++) {
pdCrntMarking[iPlace] = ppdMarking[iPlace][iStep];
}
}
if (pCManage_time || sexpRManage_time) {
double dEnd = 0;
if (pCManage_time) {
dEnd = ((double(*)(double, double *)) pCManage_time)(dTarget, pdCrntMarking);
} else {
defineVar(install("y"), sexpCrntMarking, rho);
PROTECT(sexpTmp = allocVector(REALSXP, 1));
*REAL(sexpTmp) = dTarget;
defineVar(install("StartTime"), sexpTmp, rho);
UNPROTECT_PTR(sexpTmp);
sexpTmp = eval(sexpRManage_time, rho);
dEnd = *REAL(VECTOR_ELT(sexpTmp,0));
for(iPlace = 0; iPlace < iPlaces; iPlace++) {
pdCrntMarking[iPlace] = REAL(VECTOR_ELT(sexpTmp,1))[iPlace];
}
}
iSectionSteps = (int)(dEnd / dDelta) + 1;
}
for(iPlace = 0; iPlace < iPlaces; iPlace++) {
pdBakCrntMarking[iPlace] = pdTmpCrntMarking[iPlace] = pdCrntMarking[iPlace];
}
dTime = dTarget;
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
pdHazard[iTransition] = 0;
}
do {
// Get hazards for all transitions.
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
switch(piHzType[iTransition]) {
case HZ_DOUBLE:
dNewHazard = pdH[iTransition];
for(iPlacePtr = 0; iPlacePtr < piPreNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piPreNZxRow[iTransition + iTransitions * iPlacePtr];
for (k = 0; k < piPre[iTransition + iTransitions * iPlace]; k++)
dNewHazard *= (pdCrntMarking[iPlace] - k) / (double)(k+1);
}
break;
case HZ_CFUNCTION:
dNewHazard = ((double(*)(double *)) pCFunction[iTransition])(pdCrntMarking);
break;
default:
// case HZ_RFUNCTION:
defineVar(install("y"), sexpCrntMarking, rho);
dNewHazard = REAL(eval(VECTOR_ELT(sexpFunction, iTransition), rho))[0];
break;
}
// dAcumHazard += dNewHazard - pdHazard[iTransition];
pdHazard[iTransition] = dNewHazard;
}
for(iPlace = 0; iPlace < iPlaces; iPlace++) // Save Marking
pdBakCrntMarking[iPlace] = pdCrntMarking[iPlace];
double dTau = DBL_MAX;
// Initial value of Tau
for (iPlace = 0; iPlace < iPlaces; iPlace++) {
double dMHat = 0, dSigmaHatSq = 0;
for(iTransitionPtr = 0; iTransitionPtr < piSNZxColTot[iPlace]; iTransitionPtr++) {
iTransition = piSNZxCol[iTransitionPtr + iTransitions * iPlace];
dMHat += (dTmp = piS[iTransition + iTransitions * iPlace] * pdHazard[iTransition]);
dSigmaHatSq += dTmp * piS[iTransition + iTransitions * iPlace];
}
double dE;
if ((dE = dEpsilon * pdCrntMarking[iPlace] / pdG[iPlace]) < 1)
dE = 1;
double dTLeap;
if ((dTLeap = dE/fabs(dMHat)) > (dTmp = dE*dE/dSigmaHatSq))
dTLeap = dTmp;
if (dTLeap < dTau)
dTau = dTLeap;
}
//double dLogRandom = -log(unif_rand());
//double dSSATau = DBL_MAX;
int iNextSSATransition;
int iLoop = TRUE;
while (iLoop) {
// Classify transitions
iSSATransitions = iTauLeapTransitions = iCLETransitions = iDetermTransitions = 0;
// dAcumHazard = 0;
iNextSSATransition = -1;
double dSSATau = DBL_MAX;
for(iTransition = 0; iTransition < iTransitions; iTransition++) {
if (pdHazard[iTransition] < ZERO)
continue;
if ((dTmp = pdHazard[iTransition] * dTau) < dApproxEqualOne) {
piSSATransition[iSSATransitions++] = iTransition;
// dAcumHazard += pdHazard[iTransition];
if (pdSSARescaling[iTransition] > 0) // Rescale
pdSSATau[iTransition] = pdSSARescaling[iTransition] / pdHazard[iTransition];
else { // Need to generate random number
pdSSATau[iTransition] = -log(unif_rand()) / pdHazard[iTransition];
pdSSARescaling[iTransition] = pdHazard[iTransition] * pdSSATau[iTransition];
}
if (pdSSATau[iTransition] < dSSATau) {
iNextSSATransition = iTransition;
dSSATau = pdSSATau[iTransition];
}
} else if (dTmp < dGreaterGreaterOne) {
piTauLeapTransition[iTauLeapTransitions++] = iTransition;
} else if (sqrt(dTmp) < dGreaterGreaterOne) {
piCLETransition[iCLETransitions++] = iTransition;
} else {
piDetermTransition[iDetermTransitions++] = iTransition;
}
}
if (iNextSSATransition >= 0) {
// dSSATau = dLogRandom / dAcumHazard;
if (iSSATransitions && !(iTauLeapTransitions + iCLETransitions + iDetermTransitions)) // If all (possible) transitions are SSA
dTau = dSSATau;
else if (dSSATau < dTau) { // If SSA fired before dTau
dTau = dSSATau;
continue; // Go back to see if anything changed
}
}
if (dSSATau == dTau) { // If an SSA transition fired
iTransition = iNextSSATransition;
for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr];
// Update the state
pdCrntMarking[iPlace] += piS[iTransition + iTransitions * iPlace];
}
/*
double dPartialAcumHazard = 0;
// Find out which transition happened
double dRnd = runif(0, dAcumHazard);
for(iTransitionPtr = 0; iTransitionPtr < iSSATransitions; iTransitionPtr++) {
iTransition = piSSATransition[iTransitionPtr];
if (dRnd < (dPartialAcumHazard += pdHazard[iTransition])) {
for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr];
// Update the state
pdCrntMarking[iPlace] += piS[iTransition + iTransitions * iPlace];
}
break;
}
}
*/
}
int iTransitionFires;
// Account for Tau Leaping reactions
for(iTransitionPtr = 0; iTransitionPtr < iTauLeapTransitions; iTransitionPtr++) {
iTransition = piTauLeapTransition[iTransitionPtr];
if ((iTransitionFires = rpois(pdHazard[iTransition] * dTau))) {
for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr];
// Update the state
pdCrntMarking[iPlace] += iTransitionFires * piS[iTransition + iTransitions * iPlace];
}
}
}
// Account for CLE reactions
for(iTransitionPtr = 0; iTransitionPtr < iTauLeapTransitions; iTransitionPtr++) {
iTransition = piTauLeapTransition[iTransitionPtr];
if ((iTransitionFires = fround(pdHazard[iTransition] * dTau + sqrt(pdHazard[iTransition] * dTau) * norm_rand(),0))) {
for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr];
// Update the state
pdCrntMarking[iPlace] += iTransitionFires * piS[iTransition + iTransitions * iPlace];
}
}
}
// Account for deterministic reactions
for(iTransitionPtr = 0; iTransitionPtr < iDetermTransitions; iTransitionPtr++) {
iTransition = piDetermTransition[iTransitionPtr];
if ((iTransitionFires = fround(pdHazard[iTransition] * dTau,0))) {
for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) {
iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr];
// Update the state
pdCrntMarking[iPlace] += iTransitionFires * piS[iTransition + iTransitions * iPlace];
}
}
}
// Check no negative places have been generated
for(iPlace = 0; iPlace < iPlaces; iPlace++) // Save Marking
if (pdCrntMarking[iPlace] < 0)
break;
if (iPlace < iPlaces) { // At least one Place is negative. Rollback and reduce Tau by half
dTau *= .5;
for(iPlace = 0; iPlace < iPlaces; iPlace++)
pdCrntMarking[iPlace] = pdBakCrntMarking[iPlace];
} else // Everything is OK. Leave the loop.
iLoop = FALSE;
}
// Advance the clock
dTime += dTau;
// Rescale SSA transitions that didn't fire
for(iTransitionPtr = 0; iTransitionPtr < iSSATransitions; iTransitionPtr++) {
iTransition = piSSATransition[iTransitionPtr];
if (iTransition != iNextSSATransition) {
pdSSARescaling[iTransition] = pdHazard[iTransition] * (pdSSATau[iTransition] - dTau);
} else {
pdSSARescaling[iTransition] = -1;
}
}
while (dTime >= dTarget) {
// Update the state for the fixed incremented time.
for(iPlace = 0; iPlace < iPlaces; iPlace++) {
ppdMarking[iPlace][iStep] = pdBakCrntMarking[iPlace];
}
if (++iStep >= iSectionSteps)
goto EXIT_LOOP;
dTarget += dDelta;
// Force check if user interrupted
iInterruptCnt = 1;
}
if (! --iInterruptCnt) {
// Allow user interruption
R_CheckUserInterrupt();
iInterruptCnt = 10000000;
}
} while (++iTotTransitions);
EXIT_LOOP:;
Rprintf(".");
} while (iSectionSteps < iTotalSteps);
iTotalUsedRandomNumbers += iUsedRandomNumbers;
Rprintf("\t%d\t%d\t%d", iTotTransitions, iUsedRandomNumbers, iTotalUsedRandomNumbers);
#ifdef RB_SUBTIME
c1 = clock();
Rprintf ("\t To go: ");
PrintfTime((double) (c1 - c0)/CLOCKS_PER_SEC/(iRun+1)*(iRuns-iRun-1));
#endif
Rprintf ("\n");
SEXP sexpTotTransitions;
PROTECT(sexpTotTransitions = allocVector(INTSXP, 1));
INTEGER(sexpTotTransitions)[0] = iTotTransitions;
SEXP sexpUsedRandomNumbers;
PROTECT(sexpUsedRandomNumbers = allocVector(INTSXP, 1));
INTEGER(sexpUsedRandomNumbers)[0] = iUsedRandomNumbers;
SEXP sexpThisRun;
#ifdef RB_SAVE_INCR_INFO
if (iRun >= 10)
PROTECT(sexpThisRun = allocVector(VECSXP, 4));
else
PROTECT(sexpThisRun = allocVector(VECSXP, 9));
#else
PROTECT(sexpThisRun = allocVector(VECSXP, 4));
#endif
SET_VECTOR_ELT(sexpThisRun, 0, sexpMarking);
UNPROTECT_PTR(sexpMarking);
SET_VECTOR_ELT(sexpThisRun, 1, sexpTotXTransition);
UNPROTECT_PTR(sexpTotXTransition);
SET_VECTOR_ELT(sexpThisRun, 2, sexpTotTransitions);
UNPROTECT_PTR(sexpTotTransitions);
SET_VECTOR_ELT(sexpThisRun, 3, sexpUsedRandomNumbers);
UNPROTECT_PTR(sexpUsedRandomNumbers);
#ifdef RB_SAVE_INCR_INFO
if (iRun < 10) {
SEXP sexpTmp;
PROTECT(sexpTmp = allocVector(REALSXP, iTotIncrTime));
pdTmp = REAL(sexpTmp);
int i;
for (i = 0; i < iTotIncrTime; i++)
pdTmp[i] = pdIncr[i];
SET_VECTOR_ELT(sexpThisRun, 4, sexpTmp);
UNPROTECT_PTR(sexpTmp);
PROTECT(sexpTmp = allocVector(REALSXP, iTotIncrTime));
pdTmp = REAL(sexpTmp);
for (i = 0; i < iTotIncrTime; i++)
pdTmp[i] = pdIncrTime[i];
SET_VECTOR_ELT(sexpThisRun, 5, sexpTmp);
UNPROTECT_PTR(sexpTmp);
PROTECT(sexpTmp = allocVector(REALSXP, iTotIntHazardTime));
pdTmp = REAL(sexpTmp);
for (i = 0; i < iTotIntHazardTime; i++)
pdTmp[i] = pdAcumHazard[i];
SET_VECTOR_ELT(sexpThisRun, 6, sexpTmp);
UNPROTECT_PTR(sexpTmp);
PROTECT(sexpTmp = allocVector(REALSXP, iTotIntHazardTime));
pdTmp = REAL(sexpTmp);
for (i = 0; i < iTotIntHazardTime; i++)
pdTmp[i] = pdIntHazard[i];
SET_VECTOR_ELT(sexpThisRun, 7, sexpTmp);
UNPROTECT_PTR(sexpTmp);
PROTECT(sexpTmp = allocVector(REALSXP, iTotIntHazardTime));
pdTmp = REAL(sexpTmp);
for (i = 0; i < iTotIntHazardTime; i++)
pdTmp[i] = pdIntHazardTime[i];
SET_VECTOR_ELT(sexpThisRun, 8, sexpTmp);
UNPROTECT_PTR(sexpTmp);
}
#endif
SEXP sexpNames;
#ifdef RB_SAVE_INCR_INFO
if (iRun >= 10)
PROTECT(sexpNames = allocVector(VECSXP, 4));
else
PROTECT(sexpNames = allocVector(VECSXP, 9));
#else
PROTECT(sexpNames = allocVector(VECSXP, 4));
#endif
SET_VECTOR_ELT(sexpNames, 0, mkChar("M"));
SET_VECTOR_ELT(sexpNames, 1, mkChar("transitions"));
SET_VECTOR_ELT(sexpNames, 2, mkChar("tot.transitions"));
SET_VECTOR_ELT(sexpNames, 3, mkChar("tot.rnd"));
#ifdef RB_SAVE_INCR_INFO
if (iRun < 10) {
SET_VECTOR_ELT(sexpNames, 4, mkChar("incr"));
SET_VECTOR_ELT(sexpNames, 5, mkChar("incr.time"));
SET_VECTOR_ELT(sexpNames, 6, mkChar("hazard"));
SET_VECTOR_ELT(sexpNames, 7, mkChar("int.hazard"));
SET_VECTOR_ELT(sexpNames, 8, mkChar("int.hazard.time"));
}
#endif
setAttrib(sexpThisRun, R_NamesSymbol, sexpNames);
UNPROTECT_PTR(sexpNames);
SET_VECTOR_ELT(sexpRun, iRun, sexpThisRun);
UNPROTECT_PTR(sexpThisRun);
}
PutRNGstate();
SEXP sexpAns;
PROTECT(sexpAns = allocVector(VECSXP, 4));
SET_VECTOR_ELT(sexpAns, 0, place);
SET_VECTOR_ELT(sexpAns, 1, transition);
SET_VECTOR_ELT(sexpAns, 2, sexpD_time);
UNPROTECT_PTR(sexpD_time);
SET_VECTOR_ELT(sexpAns, 3, sexpRun);
UNPROTECT_PTR(sexpRun);
SEXP sexpNames;
PROTECT(sexpNames = allocVector(VECSXP, 4));
SET_VECTOR_ELT(sexpNames, 0, mkChar("place"));
SET_VECTOR_ELT(sexpNames, 1, mkChar("transition"));
SET_VECTOR_ELT(sexpNames, 2, mkChar("dt"));
SET_VECTOR_ELT(sexpNames, 3, mkChar("run"));
setAttrib(sexpAns, R_NamesSymbol, sexpNames);
UNPROTECT_PTR(sexpNames);
#ifdef RB_TIME
c1 = clock();
double dCpuTime = (double) (c1 - c0)/CLOCKS_PER_SEC;
Rprintf ("Elapsed CPU time: ");
PrintfTime(dCpuTime);
Rprintf ("\t(%fs)\n", dCpuTime);
#endif
if (sexpRManage_time)
UNPROTECT_PTR(sexpRManage_time);
UNPROTECT_PTR(sexpFunction);
UNPROTECT_PTR(sexpMarkingRowNames);
UNPROTECT_PTR(sexpTmpCrntMarking);
UNPROTECT_PTR(sexpCrntMarking);
UNPROTECT_PTR(sexpAns);
return(sexpAns);
}
