/**
* Runs the epoch simulation for the period and updates the variables.
*
* Similar to: siena07models.cpp mlPeriod()
*
* @param m Period.
*/
void MetropolisHastingsSimulation::simulatePeriod(const int m) {
MLSimulation* pSim = new MLSimulation(lpData, lpModel);
// Update simulations
pSim->simpleRates(lpModel->simpleRates());
pSim->currentPermutationLength(lpModel->currentPermutationLength(m));
pSim->missingNetworkProbability(
static_cast<const Model*>(lpModel)->missingNetworkProbability(m));
pSim->missingBehaviorProbability(
static_cast<const Model*>(lpModel)->missingBehaviorProbability(m));
LOGS(Priority::VERBOSE)<<"\nSimple rates: "<<pSim->simpleRates()
<<"\nCurrent permutation length: "<<pSim->currentPermutationLength()
<<"\nMissing network probability: "<<pSim->missingNetworkProbability()
<<"\nMissing behavior probability: "<<pSim->missingBehaviorProbability();
pSim->pChain(lpModel->rChainStore(m).back()->copyChain());
lpModel->needScores(false);
lpModel->needDerivatives(false);
lpModel->numberMLSteps(lNRunMH[m]);
LOGS(Priority::VERBOSE)<<"\nNum steps: "<<lpModel->numberMLSteps();
pSim->runEpoch(m);
// Run through current state of chain and calculate scores and derivatives.
lpModel->needScores(true); // !onlyLoglik (bayes)
lpModel->needDerivatives(lNeedsDerivative);
pSim->updateProbabilities(pSim->pChain(), pSim->pChain()->pFirst()->pNext(),
pSim->pChain()->pLast()->pPrevious());
// Store chain on Model.
Chain* pChain = pSim->pChain();
pChain->createInitialStateDifferences();
pSim->createEndStateDifferences();
lpModel->chainStore(*pChain, m);
lpModel->currentPermutationLength(m, pSim->currentPermutationLength());
// Add up period results.
addSingleScores(lScores[0], m, *pSim);
addSingleDerivatives(lDerivative[0], m, *pSim);
LOGS(Priority::DEBUG)<<"Scores: "<<lScores[0].transpose();
}
/**
* NOTE; FOR SOME CONFIGURATIONS OF STRUCTURAL ZEROS
* THIS RUNS INTO A HANG
*/
SEXP mlMakeChains(SEXP DATAPTR, SEXP MODELPTR,
SEXP PROBS, SEXP PRMIN, SEXP PRMIB, SEXP MINIMUMPERM,
SEXP MAXIMUMPERM, SEXP INITIALPERM, SEXP LOCALML)
{
/* get hold of the data vector */
vector<Data *> * pGroupData = (vector<Data *> *)
R_ExternalPtrAddr(DATAPTR);
int nGroups = pGroupData->size();
/* find total number of periods to process */
int totObservations = totalPeriods(*pGroupData);
/* get hold of the model object */
Model * pModel = (Model *) R_ExternalPtrAddr(MODELPTR);
// create chain storage
pModel->setupChainStore(totObservations);
/* copy permutation lengths to the model */
pModel->maximumPermutationLength(REAL(MAXIMUMPERM)[0]);
pModel->minimumPermutationLength(REAL(MINIMUMPERM)[0]);
pModel->initialPermutationLength(REAL(INITIALPERM)[0]);
pModel->initializeCurrentPermutationLength();
/* set probability flags */
pModel->insertDiagonalProbability(REAL(PROBS)[0]);
pModel->cancelDiagonalProbability(REAL(PROBS)[1]);
pModel->permuteProbability(REAL(PROBS)[2]);
pModel->insertPermuteProbability(REAL(PROBS)[3]);
pModel->deletePermuteProbability(REAL(PROBS)[4]);
pModel->insertRandomMissingProbability(REAL(PROBS)[5]);
//PrintValue(PROBS);
pModel->deleteRandomMissingProbability(REAL(PROBS)[6]);
double * prmin = REAL(PRMIN);
double * prmib = REAL(PRMIB);
SEXP minimalChains;
PROTECT(minimalChains = allocVector(VECSXP, totObservations));
SEXP currentChains;
PROTECT(currentChains = allocVector(VECSXP, totObservations));
SEXP accepts;
PROTECT(accepts = allocVector(VECSXP, totObservations));
SEXP rejects;
PROTECT(rejects = allocVector(VECSXP, totObservations));
SEXP aborts;
PROTECT(aborts = allocVector(VECSXP, totObservations));
GetRNGstate();
/* localML */
int localML = 0;
if (!isNull(LOCALML))
{
localML = asInteger(LOCALML);
}
pModel->localML(localML);
int periodFromStart = 0;
for (int group = 0; group < nGroups; group++)
{
Data * pData = (*pGroupData)[group];
int observations = pData->observationCount() - 1;
/* create the ML simulation object */
MLSimulation * pMLSimulation = new MLSimulation(pData, pModel);
pMLSimulation->simpleRates(pModel->simpleRates());
for (int period = 0; period < observations; period ++)
{
// store for later on model
pModel->missingNetworkProbability(prmin[periodFromStart]);
pModel->missingBehaviorProbability(prmib[periodFromStart]);
// put ones for this period on simulation object
pMLSimulation->
missingNetworkProbability(prmin[periodFromStart]);
pMLSimulation->
missingBehaviorProbability(prmib[periodFromStart]);
pMLSimulation->currentPermutationLength(
pModel->currentPermutationLength(period));
/* initialize the chain: this also initializes the data */
// does not initialise with previous period missing values yet
pMLSimulation->pChain()->clear();
pMLSimulation->connect(period);
SEXP ch;
PROTECT(ch =
getChainDFPlus(*(pMLSimulation->pChain()), true));
SET_VECTOR_ELT(minimalChains, periodFromStart, ch);
/* get the chain up to a reasonable length */
pMLSimulation->preburnin();
/* do some more steps */
pMLSimulation->setUpProbabilityArray();
int numSteps = 500;
for (int i = 0; i < numSteps; i++)
{
pMLSimulation->MLStep();
}
/* store chain on Model after creating difference vectors */
Chain * pChain = pMLSimulation->pChain();
pMLSimulation->updateProbabilities(pChain,
pChain->pFirst()->pNext(),
pChain->pLast()->pPrevious());
pChain->createInitialStateDifferences();
pMLSimulation->createEndStateDifferences();
pModel->chainStore(*pChain, periodFromStart);
/* return chain as a list */
SEXP ch1;
PROTECT(ch1 = getChainList(*pChain));
//PROTECT(ch1 = getChainDFPlus(*pChain, true));
SET_VECTOR_ELT(currentChains, periodFromStart, ch1);
/* get hold of the statistics for accept and reject */
const vector < DependentVariable * > & rVariables =
pMLSimulation->rVariables();
int numberVariables = rVariables.size();
SEXP accepts1;
PROTECT(accepts1 = allocMatrix(INTSXP, numberVariables, 9));
SEXP rejects1;
PROTECT(rejects1 = allocMatrix(INTSXP, numberVariables, 9));
SEXP aborts1;
PROTECT(aborts1 = allocVector(INTSXP, 9));
int * iaccepts = INTEGER(accepts1);
int * irejects = INTEGER(rejects1);
int * iaborts = INTEGER(aborts1);
for (int i = 0; i < 9; i++)
{
iaborts[i] = pMLSimulation->aborted(i);
for (int j = 0; j < numberVariables; j++)
{
iaccepts[i + 9 * j] = rVariables[j]->acceptances(i);
irejects[i + 9 * j] = rVariables[j]->rejections(i);
}
}
SET_VECTOR_ELT(accepts, periodFromStart, accepts1);
SET_VECTOR_ELT(rejects, periodFromStart, rejects1);
SET_VECTOR_ELT(aborts, periodFromStart, aborts1);
periodFromStart++;
pModel->currentPermutationLength(period,
pMLSimulation->currentPermutationLength());
}
delete pMLSimulation;
}
SEXP ans;
PROTECT(ans = allocVector(VECSXP, 5));
SET_VECTOR_ELT(ans, 0, minimalChains);
SET_VECTOR_ELT(ans, 1, currentChains);
SET_VECTOR_ELT(ans, 2, accepts);
SET_VECTOR_ELT(ans, 3, rejects);
SET_VECTOR_ELT(ans, 4, aborts);
PutRNGstate();
int nbrProtects = 6 + 5 * totObservations;
UNPROTECT(nbrProtects);
return ans;
}