/**
 * 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();
}
예제 #2
0
/**
  * 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;
}