void SetDim2(SEXP array, int x1, int x2)
{
SEXP _dim;
PROTECT(_dim = NEW_INTEGER(2));
INTEGER_POINTER(_dim)[0] = x1;
INTEGER_POINTER(_dim)[1] = x2;
SET_DIM(array, _dim);
UNPROTECT_PTR(_dim);
}
void SetDim3(SEXP array, int x1, int x2, int x3)
{
SEXP _dim;
PROTECT(_dim = NEW_INTEGER(3));
INTEGER_POINTER(_dim)[0] = x1;
INTEGER_POINTER(_dim)[1] = x2;
INTEGER_POINTER(_dim)[2] = x3;
SET_DIM(array, _dim);
UNPROTECT_PTR(_dim);
}
void SetListElement(SEXP list, int i, const char *tag, SEXP value)
{
SEXP _names = getAttrib(list, R_NamesSymbol);
if (_names == R_NilValue)
{
PROTECT(_names = NEW_STRING(length(list)));
SET_STRING_ELT(_names, i, mkChar(tag));
setAttrib(list, R_NamesSymbol, _names);
UNPROTECT_PTR(_names);
}
else
SET_STRING_ELT(_names, i, mkChar(tag));
SET_VECTOR_ELT(list, i, value);
}
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);
}
SEXP attribute_hidden do_readDCF(SEXP call, SEXP op, SEXP args, SEXP env)
{
int nwhat, nret, nc, nr, m, k, lastm, need;
Rboolean blank_skip, field_skip = FALSE;
int whatlen, dynwhat, buflen = 8096; // was 100, but that re-alloced often
char *line, *buf;
regex_t blankline, contline, trailblank, regline, eblankline;
regmatch_t regmatch[1];
SEXP file, what, what2, retval, retval2, dims, dimnames;
Rconnection con = NULL;
Rboolean wasopen, is_eblankline;
RCNTXT cntxt;
SEXP fold_excludes;
Rboolean field_fold = TRUE, has_fold_excludes;
const char *field_name;
int offset = 0; /* -Wall */
checkArity(op, args);
file = CAR(args);
con = getConnection(asInteger(file));
wasopen = con->isopen;
if(!wasopen) {
if(!con->open(con)) error(_("cannot open the connection"));
/* Set up a context which will close the connection on error */
begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &con_cleanup;
cntxt.cenddata = con;
}
if(!con->canread) error(_("cannot read from this connection"));
args = CDR(args);
PROTECT(what = coerceVector(CAR(args), STRSXP)); /* argument fields */
nwhat = LENGTH(what);
dynwhat = (nwhat == 0);
args = CDR(args);
PROTECT(fold_excludes = coerceVector(CAR(args), STRSXP));
has_fold_excludes = (LENGTH(fold_excludes) > 0);
buf = (char *) malloc(buflen);
if(!buf) error(_("could not allocate memory for 'read.dcf'"));
nret = 20;
/* it is easier if we first have a record per column */
PROTECT(retval = allocMatrixNA(STRSXP, LENGTH(what), nret));
/* These used to use [:blank:] but that can match \xa0 as part of
a UTF-8 character (and is nbspace on Windows). */
tre_regcomp(&blankline, "^[[:blank:]]*$", REG_NOSUB & REG_EXTENDED);
tre_regcomp(&trailblank, "[ \t]+$", REG_EXTENDED);
tre_regcomp(&contline, "^[[:blank:]]+", REG_EXTENDED);
tre_regcomp(®line, "^[^:]+:[[:blank:]]*", REG_EXTENDED);
tre_regcomp(&eblankline, "^[[:space:]]+\\.[[:space:]]*$", REG_EXTENDED);
k = 0;
lastm = -1; /* index of the field currently being recorded */
blank_skip = TRUE;
void *vmax = vmaxget();
while((line = Rconn_getline2(con))) {
if(strlen(line) == 0 ||
tre_regexecb(&blankline, line, 0, 0, 0) == 0) {
/* A blank line. The first one after a record ends a new
* record, subsequent ones are skipped */
if(!blank_skip) {
k++;
if(k > nret - 1){
nret *= 2;
PROTECT(retval2 = allocMatrixNA(STRSXP, LENGTH(what), nret));
transferVector(retval2, retval);
UNPROTECT_PTR(retval);
retval = retval2;
}
blank_skip = TRUE;
lastm = -1;
field_skip = FALSE;
field_fold = TRUE;
}
} else {
blank_skip = FALSE;
if(tre_regexecb(&contline, line, 1, regmatch, 0) == 0) {
/* A continuation line: wrong if at the beginning of a
record. */
if((lastm == -1) && !field_skip) {
line[20] = '\0';
error(_("Found continuation line starting '%s ...' at begin of record."),
line);
}
if(lastm >= 0) {
need = (int) strlen(CHAR(STRING_ELT(retval,
lastm + nwhat * k))) + 2;
if(tre_regexecb(&eblankline, line, 0, NULL, 0) == 0) {
is_eblankline = TRUE;
} else {
is_eblankline = FALSE;
if(field_fold) {
offset = regmatch[0].rm_eo;
/* Also remove trailing whitespace. */
if((tre_regexecb(&trailblank, line, 1,
regmatch, 0) == 0))
line[regmatch[0].rm_so] = '\0';
} else {
offset = 0;
}
need += (int) strlen(line + offset);
}
if(buflen < need) {
char *tmp = (char *) realloc(buf, need);
if(!tmp) {
free(buf);
error(_("could not allocate memory for 'read.dcf'"));
} else buf = tmp;
buflen = need;
}
strcpy(buf,CHAR(STRING_ELT(retval, lastm + nwhat * k)));
strcat(buf, "\n");
if(!is_eblankline) strcat(buf, line + offset);
SET_STRING_ELT(retval, lastm + nwhat * k, mkChar(buf));
}
} else {
if(tre_regexecb(®line, line, 1, regmatch, 0) == 0) {
for(m = 0; m < nwhat; m++){
whatlen = (int) strlen(CHAR(STRING_ELT(what, m)));
if(strlen(line) > whatlen &&
line[whatlen] == ':' &&
strncmp(CHAR(STRING_ELT(what, m)),
line, whatlen) == 0) {
/* An already known field we are recording. */
lastm = m;
field_skip = FALSE;
field_name = CHAR(STRING_ELT(what, lastm));
if(has_fold_excludes) {
field_fold =
field_is_foldable_p(field_name,
fold_excludes);
}
if(field_fold) {
offset = regmatch[0].rm_eo;
/* Also remove trailing whitespace. */
if((tre_regexecb(&trailblank, line, 1,
regmatch, 0) == 0))
line[regmatch[0].rm_so] = '\0';
} else {
offset = 0;
}
SET_STRING_ELT(retval, m + nwhat * k,
mkChar(line + offset));
break;
} else {
/* This is a field, but not one prespecified */
lastm = -1;
field_skip = TRUE;
}
}
if(dynwhat && (lastm == -1)) {
/* A previously unseen field and we are
* recording all fields */
field_skip = FALSE;
PROTECT(what2 = allocVector(STRSXP, nwhat+1));
PROTECT(retval2 = allocMatrixNA(STRSXP,
nrows(retval)+1,
ncols(retval)));
if(nwhat > 0) {
copyVector(what2, what);
for(nr = 0; nr < nrows(retval); nr++){
for(nc = 0; nc < ncols(retval); nc++){
SET_STRING_ELT(retval2, nr+nc*nrows(retval2),
STRING_ELT(retval,
nr+nc*nrows(retval)));
}
}
}
UNPROTECT_PTR(retval);
UNPROTECT_PTR(what);
retval = retval2;
what = what2;
/* Make sure enough space was used */
need = (int) (Rf_strchr(line, ':') - line + 1);
if(buflen < need){
char *tmp = (char *) realloc(buf, need);
if(!tmp) {
free(buf);
error(_("could not allocate memory for 'read.dcf'"));
} else buf = tmp;
buflen = need;
}
strncpy(buf, line, Rf_strchr(line, ':') - line);
buf[Rf_strchr(line, ':') - line] = '\0';
SET_STRING_ELT(what, nwhat, mkChar(buf));
nwhat++;
/* lastm uses C indexing, hence nwhat - 1 */
lastm = nwhat - 1;
field_name = CHAR(STRING_ELT(what, lastm));
if(has_fold_excludes) {
field_fold =
field_is_foldable_p(field_name,
fold_excludes);
}
offset = regmatch[0].rm_eo;
if(field_fold) {
/* Also remove trailing whitespace. */
if((tre_regexecb(&trailblank, line, 1,
regmatch, 0) == 0))
line[regmatch[0].rm_so] = '\0';
}
SET_STRING_ELT(retval, lastm + nwhat * k,
mkChar(line + offset));
}
} else {
/* Must be a regular line with no tag ... */
line[20] = '\0';
error(_("Line starting '%s ...' is malformed!"), line);
}
}
}
}
vmaxset(vmax);
if(!wasopen) {endcontext(&cntxt); con->close(con);}
free(buf);
tre_regfree(&blankline);
tre_regfree(&contline);
tre_regfree(&trailblank);
tre_regfree(®line);
tre_regfree(&eblankline);
if(!blank_skip) k++;
/* and now transpose the whole matrix */
PROTECT(retval2 = allocMatrixNA(STRSXP, k, LENGTH(what)));
copyMatrix(retval2, retval, 1);
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dims = allocVector(INTSXP, 2));
INTEGER(dims)[0] = k;
INTEGER(dims)[1] = LENGTH(what);
SET_VECTOR_ELT(dimnames, 1, what);
setAttrib(retval2, R_DimSymbol, dims);
setAttrib(retval2, R_DimNamesSymbol, dimnames);
UNPROTECT(6);
return(retval2);
}
~BackendBase() {
if (Robject != R_NilValue) { UNPROTECT_PTR(Robject); }
}
/* just the interface function */
SEXP computeStandardEyemeasuresExt(SEXP positionsArg, SEXP fixationTimesArg,
SEXP fixationStartArg, SEXP fixationEndArg,
SEXP trialIdArg, SEXP trialInfoArg,
SEXP nrOfROIsArg, SEXP nrOfTrialsArg,
SEXP cutoffArg, SEXP cutoffLengthArg,
SEXP regressiveFirstPassArg, SEXP useTimeIntervalsArg)
{
LOG(("<computeStandardEyemeasuresExt>\n"))
/* process arguments */
CStandardMeasures m(positionsArg, fixationTimesArg,
fixationStartArg, fixationEndArg,
trialIdArg, trialInfoArg,
nrOfROIsArg, nrOfTrialsArg,
cutoffArg, cutoffLengthArg,
useTimeIntervalsArg );
bool regressiveFirstPass = LOGICAL_VALUE(regressiveFirstPassArg);
int nrOfTrials = INTEGER_VALUE(nrOfTrialsArg);
if(nrOfTrials < 0) nrOfTrials = 0;
/* do computations */
m.computeStandardEyemeasures(regressiveFirstPass);
// handle returning stuff
SEXP listRet, listNamesRet;
const int resultVectorsCnt = 1 + 14; // 1 extra for roi
// set the names vector
SPROTECT(listNamesRet = allocVector(STRSXP, resultVectorsCnt+length(trialInfoArg)));
SPROTECT(listRet = allocVector(VECSXP, resultVectorsCnt+length(trialInfoArg)));
// add info elements
SEXP trialInfoNames = getAttrib(trialInfoArg, R_NamesSymbol);
int rListAppendCnt=0;
for( int i=0; i < length(trialInfoArg); i++)
APPEND_RET_VEC ( CHAR(STRING_ELT(trialInfoNames, i)), m.trialInfoR[i]);
// add result vectors
APPEND_RET_VEC( "roi", m.positionsR); // attaching ROIs vector to list
APPEND_RET_VEC( "FFD", m.ffdR); // FFD (first fixation duration)
APPEND_RET_VEC( "FFP", m.ffpR); // FFP (first fixation progressive)
APPEND_RET_VEC( "SFD", m.sfdR); // SFD (single fixation duration)
APPEND_RET_VEC( "FPRT", m.fprtR); // FPRT (first pass reading time / gaze duration)
APPEND_RET_VEC( "RBRT", m.rbrtR); // RBRT (right bounded reading time)
APPEND_RET_VEC( "TFT", m.tftR); // TFT (total fixation time)
APPEND_RET_VEC( "RPD", m.rpdR); // RPD (regression path duration)
APPEND_RET_VEC( "CRPD", m.crpdR); // CRPD (cumulative regression path duration)
APPEND_RET_VEC( "RRT", m.rrtR); // RRT (re-reading time)
APPEND_RET_VEC( "RRTP", m.rrtpR); // RRTP (re-reading time progressive)
APPEND_RET_VEC( "RRTR", m.rrtrR); // RRTR (re-reading time regressive)
APPEND_RET_VEC( "RBRC", m.rbrcR); // RBRC (first-pass regression count)
APPEND_RET_VEC( "TRC", m.trcR); // TRC (total regression count)
APPEND_RET_VEC( "LPRT", m.lprtR); // LPRT (last pass reading time)
setAttrib(listRet, R_NamesSymbol, listNamesRet); //and attaching the vector names
UNPROTECT_PTR(listRet);
UNPROTECT_PTR(listNamesRet);
LOG(("</computeStandardEyemeasuresExt>\n"))
return(listRet);
}
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);
}
