void SummStats(Edge n_edges, Vertex *tails, Vertex *heads,
Network *nwp, Model *m, double *stats){
GetRNGstate(); /* R function enabling uniform RNG */
ShuffleEdges(tails,heads,n_edges); /* Shuffle edgelist. */
for (unsigned int termi=0; termi < m->n_terms; termi++)
m->termarray[termi].dstats = m->workspace;
/* Doing this one toggle at a time saves a lot of toggles... */
for(Edge e=0; e<n_edges; e++){
ModelTerm *mtp = m->termarray;
double *statspos=stats;
for (unsigned int termi=0; termi < m->n_terms; termi++, mtp++){
if(!mtp->s_func){
(*(mtp->d_func))(1, tails+e, heads+e,
mtp, nwp); /* Call d_??? function */
for (unsigned int i=0; i < mtp->nstats; i++,statspos++)
*statspos += mtp->dstats[i];
}else statspos += mtp->nstats;
}
ToggleEdge(tails[e],heads[e],nwp);
}
ModelTerm *mtp = m->termarray;
double *dstats = m->workspace;
double *statspos=stats;
for (unsigned int termi=0; termi < m->n_terms; termi++, dstats+=mtp->nstats, mtp++ ){
if(mtp->s_func){
(*(mtp->s_func))(mtp, nwp); /* Call s_??? function */
for (unsigned int i=0; i < mtp->nstats; i++,statspos++)
*statspos = mtp->dstats[i];
}else statspos += mtp->nstats;
}
PutRNGstate();
}
void RecurseOffOn(
Vertex *nodelist1,
Vertex *nodelist2,
Vertex nodelistlength,
Vertex currentnodes,
double *changeStats,
double *cumulativeStats,
double *covmat,
unsigned int *weightsvector,
unsigned int maxNumDyadTypes,
Network *nwp,
Model *m) {
ModelTerm *mtp;
/* Loop through twice for each dyad: Once for edge and once for no edge */
for (int i=0; i<2; i++) {
/* Recurse if currentnodes+1 is not yet nodelistlength */
if (currentnodes+1 < nodelistlength) {
RecurseOffOn(nodelist1, nodelist2, nodelistlength, currentnodes+1, changeStats,
cumulativeStats, covmat, weightsvector, maxNumDyadTypes, nwp, m);
} else { /* Add newRow of statistics to hash table */
//Rprintf("Here's network number %d with changestat %f\n",counter++, changeStats[0]);
//NetworkEdgeList(nwp);
if(!InsNetStatRow(cumulativeStats, covmat, m->n_stats, maxNumDyadTypes, weightsvector)) {
error("Too many unique dyads!");
}
}
/* Calculate the change statistic(s) associated with toggling the
dyad represented by nodelist1[currentnodes], nodelist2[currentnodes] */
for (mtp=m->termarray; mtp < m->termarray + m->n_terms; mtp++){
(*(mtp->d_func))(1, (Vertex*)nodelist1+currentnodes, (Vertex*)nodelist2+currentnodes, mtp, nwp);
}
for (int j=0; j < m->n_stats; j++) cumulativeStats[j] += changeStats[j];
/* Now toggle the dyad so it's ready for the next pass */
ToggleEdge(nodelist1[currentnodes], nodelist2[currentnodes], nwp);
}
}
/*********************
void MetropolisHastings
In this function, theta is a m->n_stats-vector just as in MCMCSample,
but now networkstatistics is merely another m->n_stats-vector because
this function merely iterates nsteps times through the Markov
chain, keeping track of the cumulative change statistics along
the way, then returns, leaving the updated change statistics in
the networkstatistics vector. In other words, this function
essentially generates a sample of size one
*********************/
MCMCStatus MetropolisHastings(MHproposal *MHp,
double *theta, double *networkstatistics,
int nsteps, int *staken,
int fVerbose,
Network *nwp,
Model *m) {
unsigned int taken=0, unsuccessful=0;
/* if (fVerbose)
Rprintf("Now proposing %d MH steps... ", nsteps); */
for(unsigned int step=0; step < nsteps; step++) {
MHp->logratio = 0;
(*(MHp->func))(MHp, nwp); /* Call MH function to propose toggles */
if(MHp->toggletail[0]==MH_FAILED){
if(MHp->togglehead[0]==MH_UNRECOVERABLE)
error("Something very bad happened during proposal. Memory has not been deallocated, so restart R soon.");
if(MHp->togglehead[0]==MH_IMPOSSIBLE){
Rprintf("MH Proposal function encountered a configuration from which no toggle(s) can be proposed.\n");
return MCMC_MH_FAILED;
}
if(MHp->togglehead[0]==MH_UNSUCCESSFUL){
warning("MH Proposal function failed to find a valid proposal.");
unsuccessful++;
if(unsuccessful>taken*MH_QUIT_UNSUCCESSFUL){
Rprintf("Too many MH Proposal function failures.\n");
return MCMC_MH_FAILED;
}
continue;
}
}
if(fVerbose>=5){
Rprintf("Proposal: ");
for(unsigned int i=0; i<MHp->ntoggles; i++)
Rprintf(" (%d, %d)", MHp->toggletail[i], MHp->togglehead[i]);
Rprintf("\n");
}
/* Calculate change statistics,
remembering that tail -> head */
ChangeStats(MHp->ntoggles, MHp->toggletail, MHp->togglehead, nwp, m);
if(fVerbose>=5){
Rprintf("Changes: (");
for(unsigned int i=0; i<m->n_stats; i++)
Rprintf(" %f ", m->workspace[i]);
Rprintf(")\n");
}
/* Calculate inner product */
double ip=0;
for (unsigned int i=0; i<m->n_stats; i++){
ip += theta[i] * m->workspace[i];
}
/* The logic is to set cutoff = ip+logratio ,
then let the MH probability equal min{exp(cutoff), 1.0}.
But we'll do it in log space instead. */
double cutoff = ip + MHp->logratio;
if(fVerbose>=5){
Rprintf("log acceptance probability: %f + %f = %f\n", ip, MHp->logratio, cutoff);
}
/* if we accept the proposed network */
if (cutoff >= 0.0 || log(unif_rand()) < cutoff) {
if(fVerbose>=5){
Rprintf("Accepted.\n");
}
/* Make proposed toggles (updating timestamps--i.e., for real this time) */
for(unsigned int i=0; i < MHp->ntoggles; i++){
ToggleEdge(MHp->toggletail[i], MHp->togglehead[i], nwp);
if(MHp->discord)
for(Network **nwd=MHp->discord; *nwd!=NULL; nwd++){
ToggleEdge(MHp->toggletail[i], MHp->togglehead[i], *nwd);
}
}
/* record network statistics for posterity */
for (unsigned int i = 0; i < m->n_stats; i++){
networkstatistics[i] += m->workspace[i];
}
taken++;
}else{
if(fVerbose>=5){
Rprintf("Rejected.\n");
}
}
}
*staken = taken;
return MCMC_OK;
}
/*********************
MCMCStatus SANMetropolisHastings
In this function, theta is a m->n_stats-vector just as in SANSample,
but now networkstatistics is merely another m->n_stats-vector because
this function merely iterates nsteps times through the Markov
chain, keeping track of the cumulative change statistics along
the way, then returns, leaving the updated change statistics in
the networkstatistics vector. In other words, this function
essentially generates a sample of size one
*********************/
MCMCStatus SANMetropolisHastings (MHproposal *MHp,
double *theta, double *invcov,
double *tau, double *networkstatistics,
int nsteps, int *staken,
int fVerbose,
Network *nwp,
Model *m, Network *y0) {
unsigned int taken=0, unsuccessful=0;
double *deltainvsig, *delta;
deltainvsig = (double *)malloc( m->n_stats * sizeof(double));
delta = (double *)malloc( m->n_stats * sizeof(double));
/* if (fVerbose)
Rprintf("Now proposing %d MH steps... ", nsteps); */
for(unsigned int step=0; step < nsteps; step++) {
MHp->logratio = 0;
(*(MHp->func))(MHp, nwp); /* Call MH function to propose toggles */
if(MHp->toggletail[0]==MH_FAILED){
if(MHp->togglehead[0]==MH_UNRECOVERABLE)
error("Something very bad happened during proposal. Memory has not been deallocated, so restart R soon.");
if(MHp->togglehead[0]==MH_IMPOSSIBLE){
Rprintf("MH Proposal function encountered a configuration from which no toggle(s) can be proposed.\n");
return MCMC_MH_FAILED;
}
if(MHp->togglehead[0]==MH_UNSUCCESSFUL){
warning("MH Proposal function failed to find a valid proposal.");
unsuccessful++;
if(unsuccessful>taken*MH_QUIT_UNSUCCESSFUL){
Rprintf("Too many MH Proposal function failures.\n");
return MCMC_MH_FAILED;
}
continue;
}
}
/*toggle node*/
if(MHp->toggletail[0]==MH_NODE & MHp->togglehead[0]==MH_NODE){
if(fVerbose>=4)
Rprintf("Toggle Node %d \n", MHp->togglenode[0]);
} else if(MHp->togglenode[0]==0){/*toggle dyad*/
if(fVerbose>=4)
Rprintf("Toggle Dyad %d-%d \n", MHp->toggletail[0],MHp->togglehead[0]);
} else{
if(fVerbose>=4)
Rprintf("Something wrong in selecting toggle \n");
}
if(fVerbose>=5){
Rprintf("Proposal: ");
for(unsigned int i=0; i<MHp->ntoggles; i++)
Rprintf(" (%d, %d)", MHp->toggletail[i], MHp->togglehead[i]);
Rprintf("\n");
}
/* Calculate change statistics,
remembering that tail -> head */
ChangeStats(MHp->ntoggles, MHp->toggletail, MHp->togglehead, MHp->togglenode, nwp, m, y0);
if(fVerbose>=5){
Rprintf("Changes: (");
for(unsigned int i=0; i<m->n_stats; i++)
Rprintf(" %f ", m->workspace[i]);
Rprintf(")\n");
}
/* Calculate inner product */
double ip=0, dif=0;
for (unsigned int i=0; i<m->n_stats; i++){
delta[i]=0.0;
deltainvsig[i]=0.0;
for (unsigned int j=0; j<m->n_stats; j++){
delta[i]+=networkstatistics[j]*invcov[i+(m->n_stats)*j];
deltainvsig[i]+=(m->workspace[j])*invcov[i+(m->n_stats)*j];
}
ip+=deltainvsig[i]*((m->workspace[i])+2.0*networkstatistics[i]);
dif+=delta[i]*networkstatistics[i];
}
if(fVerbose>=5){
Rprintf("log acceptance probability: %f\n", ip);
}
/* if we accept the proposed network */
if (ip <= 0.0) {
// if (ip <= 0.0 || (ip/dif) < 0.001) {
// if (div > 0.0 && (ip < 0.0 || unif_rand() < 0.01)) {
// if (ip <= 0.0 || (ip/dif) < (nsteps-step)*0.001*tau[0]/(1.0*nsteps)) {
// if (ip > exp(theta[0])*(m->n_stats)*unif_rand()/(1.0+exp(theta[0])) {
// if (ip > tau[0]*(m->n_stats)*unif_rand()) {
if(fVerbose>=5){
Rprintf("Accepted.\n");
}
/* Make proposed toggles (updating timestamps--i.e., for real this time) */
for(unsigned int i=0; i < MHp->ntoggles; i++){
ToggleEdge(MHp->toggletail[i], MHp->togglehead[i], nwp);
if(MHp->discord)
for(Network **nwd=MHp->discord; *nwd!=NULL; nwd++){
ToggleEdge(MHp->toggletail[i], MHp->togglehead[i], *nwd);
}
}
/* record network statistics for posterity */
for (unsigned int i = 0; i < m->n_stats; i++){
networkstatistics[i] += m->workspace[i];
}
taken++;
}else{
if(fVerbose>=5){
Rprintf("Rejected.\n");
}
}
}
free(deltainvsig);
free(delta);
*staken = taken;
return MCMC_OK;
}
void SummStats(Edge n_edges, Vertex n_nodes, Vertex *tails, Vertex *heads,
Network *nwp, Model *m, double *stats, Network *y0){
Vertex *nodes; /*may need to change*/
nodes = (Vertex *)malloc( 1 * sizeof(Vertex));
GetRNGstate(); /* R function enabling uniform RNG */
ShuffleEdges(tails,heads,n_edges); /* Shuffle edgelist. */
for (unsigned int termi=0; termi < m->n_terms; termi++)
m->termarray[termi].dstats = m->workspace;
/* Doing this one toggle at a time saves a lot of toggles... */
for(Edge e=0; e<n_edges; e++){
ModelTerm *mtp = m->termarray;
double *statspos=stats;
nodes[0] = 0;
for (unsigned int termi=0; termi < m->n_terms; termi++, mtp++){
if(!mtp->s_func){
(*(mtp->d_func))(1, tails+e, heads+e, nodes,
mtp, nwp, y0); /* Call d_??? function */
for (unsigned int i=0; i < mtp->nstats; i++,statspos++)
*statspos += mtp->dstats[i];
}else statspos += mtp->nstats;
}
ToggleEdge(tails[e],heads[e],nwp);
}
/* Doing this one toggle at a time saves a lot of toggles... */
for(int v=0; v<n_nodes; v++){
if(m->nodalstatus[v]== 2.0){
nodes[0] = (int) (v+1);
ModelTerm *mtp = m->termarray;
double *statspos=stats;
for (unsigned int termi=0; termi < m->n_terms; termi++, mtp++){
if(!mtp->s_func){
(*(mtp->d_func))(1, tails, heads, nodes,
mtp, nwp, y0); /* Call d_??? function */
for (unsigned int i=0; i < mtp->nstats; i++,statspos++)
*statspos += mtp->dstats[i];
}else statspos += mtp->nstats;
}
ToggleNode(v+1,nwp);
}
}
ModelTerm *mtp = m->termarray;
double *dstats = m->workspace;
double *statspos=stats;
for (unsigned int termi=0; termi < m->n_terms; termi++, dstats+=mtp->nstats, mtp++ ){
if(mtp->s_func){
(*(mtp->s_func))(mtp, nwp); /* Call s_??? function */
for (unsigned int i=0; i < mtp->nstats; i++,statspos++)
*statspos = mtp->dstats[i];
}else statspos += mtp->nstats;
}
PutRNGstate();
}
