/****************
void SummStats Computes summary statistics for a network. Must be
passed an empty network (and a possible discordance network) and
passed an empty network
*****************/
void WtSummStats(Edge n_edges, Vertex *tails, Vertex *heads, double *weights,
WtNetwork *nwp, WtModel *m, double *stats){
GetRNGstate(); /* R function enabling uniform RNG */
WtShuffleEdges(tails,heads,weights,n_edges); /* Shuffle edgelist. */
for (unsigned int termi=0; termi < m->n_terms; termi++)
m->termarray[termi].dstats = m->workspace;
/* Doing this one edge at a time saves a lot of toggles... */
for(Edge e=0; e<n_edges; e++){
WtModelTerm *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, weights+e,
mtp, nwp); /* Call d_??? function */
for (unsigned int i=0; i < mtp->nstats; i++,statspos++)
*statspos += mtp->dstats[i];
}else statspos += mtp->nstats;
}
WtSetEdge(tails[e],heads[e],weights[e],nwp);
}
WtModelTerm *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();
}
/*********************
MCMCStatus WtSANMetropolisHastings
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
*********************/
WtMCMCStatus WtSANMetropolisHastings (WtMHproposal *MHp,
double *theta, double *invcov,
double *tau, double *networkstatistics,
int nsteps, int *staken,
int fVerbose,
WtNetwork *nwp,
WtModel *m) {
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 WtMH 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 WtMCMC_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 WtMCMC_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 */
WtChangeStats(MHp->ntoggles, MHp->toggletail, MHp->togglehead, MHp->toggleweight, 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, 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++){
Vertex t=MHp->toggletail[i], h=MHp->togglehead[i];
double w=MHp->toggleweight[i];
if(MHp->discord)
for(WtNetwork **nwd=MHp->discord; *nwd!=NULL; nwd++){
// This could be speeded up by implementing an "incrementation" function.
WtSetEdge(t, h, WtGetEdge(t, h, *nwd) + w - WtGetEdge(t, h, nwp), *nwd);
}
WtSetEdge(t, h, w, nwp);
}
/* 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 WtMCMC_OK;
}
/*********************
void MetropolisHastings
In this function, theta is a m->n_stats-vector just as in WtMCMCSample,
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
*********************/
WtMCMCStatus WtMetropolisHastings (WtMHproposal *MHp,
double *theta, double *networkstatistics,
int nsteps, int *staken,
int fVerbose,
WtNetwork *nwp,
WtModel *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 WtMCMC_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 WtMCMC_MH_FAILED;
}
continue;
}
}
if(fVerbose>=5){
Rprintf("Proposal: ");
for(unsigned int i=0; i<MHp->ntoggles; i++)
Rprintf(" (%d, %d) -> %f ", MHp->toggletail[i], MHp->togglehead[i], MHp->toggleweight[i]);
Rprintf("\n");
}
/* Calculate change statistics,
remembering that tail -> head */
WtChangeStats(MHp->ntoggles, MHp->toggletail, MHp->togglehead, MHp->toggleweight, 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++){
WtSetEdge(MHp->toggletail[i], MHp->togglehead[i], MHp->toggleweight[i], nwp);
if(MHp->discord)
for(WtNetwork **nwd=MHp->discord; *nwd!=NULL; nwd++){
// This could be speeded up by implementing an "incrementation" function.
WtSetEdge(MHp->toggletail[i], MHp->togglehead[i], MHp->toggleweight[i]-WtGetEdge(MHp->toggletail[i], MHp->togglehead[i], *nwd) + MHp->toggleweight[i]-WtGetEdge(MHp->toggletail[i], MHp->togglehead[i], nwp), *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 WtMCMC_OK;
}
/*********************
void MetropolisHastings
In this function, theta is a m->n_stats-vector just as in WtCDSample,
but now networkstatistics is merely another m->n_stats-vector because
this function merely iterates nsteps=CDparams[0] 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
*********************/
WtMCMCStatus WtCDStep (WtMHproposal *MHp,
double *theta, double *networkstatistics,
int *CDparams, int *staken, Vertex *undotail, Vertex *undohead, double *undoweight,
int fVerbose,
WtNetwork *nwp,
WtModel *m, double *extraworkspace) {
unsigned int unsuccessful=0, ntoggled=0;
for(unsigned int step=0; step<CDparams[0]; step++){
unsigned int mtoggled=0;
memset(extraworkspace, 0, m->n_stats*sizeof(double));
double cumlr = 0;
for(unsigned int mult=0; mult<CDparams[1]; mult++){
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 WtMCMC_MH_FAILED;
}
if(MHp->togglehead[0]==MH_UNSUCCESSFUL){
warning("MH Proposal function failed to find a valid proposal.");
unsuccessful++;
if(unsuccessful>MH_QUIT_UNSUCCESSFUL){
Rprintf("Too many MH Proposal function failures.\n");
return WtMCMC_MH_FAILED;
}
return MH_UNSUCCESSFUL;
}
}
if(fVerbose>=5){
Rprintf("Proposal: ");
for(unsigned int i=0; i<MHp->ntoggles; i++)
Rprintf(" (%d, %d) -> %f ", MHp->toggletail[i], MHp->togglehead[i], MHp->toggleweight[i]);
Rprintf("\n");
}
/* Calculate change statistics,
remembering that tail -> head */
WtChangeStats(MHp->ntoggles, MHp->toggletail, MHp->togglehead, MHp->toggleweight, nwp, m);
// Add them to the cumulative changes.
for(unsigned int i=0; i<m->n_stats; i++)
extraworkspace[i] += m->workspace[i];
if(fVerbose>=5){
Rprintf("Changes: (");
for(unsigned int i=0; i<m->n_stats; i++){
Rprintf(" %f ", m->workspace[i]);
}
Rprintf(")\n");
}
if(mult<CDparams[1]-1){
/* Make proposed toggles provisionally. */
for(unsigned int i=0; i < MHp->ntoggles; i++){
Vertex t=MHp->toggletail[i], h=MHp->togglehead[i];
double w=MHp->toggleweight[i];
undotail[ntoggled]=t;
undohead[ntoggled]=h;
undoweight[ntoggled]=WtGetEdge(MHp->toggletail[i], MHp->togglehead[i], nwp);
ntoggled++;
mtoggled++;
if(MHp->discord)
for(WtNetwork **nwd=MHp->discord; *nwd!=NULL; nwd++){
// This could be speeded up by implementing an "incrementation" function.
WtSetEdge(t, h, WtGetEdge(t, h, *nwd) + w - WtGetEdge(t, h, nwp), *nwd);
}
WtSetEdge(t, h, w, nwp);
}
}
// Accumulate the log acceptance ratio.
cumlr += MHp->logratio;
} // mult
if(fVerbose>=5){
Rprintf("Cumulative changes: (");
for(unsigned int i=0; i<m->n_stats; i++)
Rprintf(" %f ", extraworkspace[i]);
Rprintf(")\n");
}
/* Calculate inner product */
double ip=0;
for (unsigned int i=0; i<m->n_stats; i++){
ip += theta[i] * extraworkspace[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 + cumlr;
if(fVerbose>=5){
Rprintf("log acceptance probability: %f + %f = %f\n", ip, cumlr, cutoff);
}
/* if we accept the proposed network */
if (cutoff >= 0.0 || log(unif_rand()) < cutoff) {
if(fVerbose>=5){
Rprintf("Accepted.\n");
}
(*staken)++;
if(step<CDparams[0]-1){
/* Make the remaining proposed toggles (which we did not make provisionally) */
for(unsigned int i=0; i < MHp->ntoggles; i++){
Vertex t=MHp->toggletail[i], h=MHp->togglehead[i];
double w=MHp->toggleweight[i];
undotail[ntoggled]=t;
undohead[ntoggled]=h;
undoweight[ntoggled]=WtGetEdge(MHp->toggletail[i], MHp->togglehead[i], nwp);
ntoggled++;
if(MHp->discord)
for(WtNetwork **nwd=MHp->discord; *nwd!=NULL; nwd++){
// This could be speeded up by implementing an "incrementation" function.
WtSetEdge(t, h, WtGetEdge(t, h, *nwd) + w - WtGetEdge(t, h, nwp), *nwd);
}
WtSetEdge(t, h, w, nwp);
}
}
/* record network statistics for posterity */
for (unsigned int i = 0; i < m->n_stats; i++){
networkstatistics[i] += extraworkspace[i];
}
}else{
if(fVerbose>=5){
Rprintf("Rejected.\n");
}
// Undo the provisional toggles (the last mtoggled ones)
for(unsigned int i=0; i < mtoggled; i++){
ntoggled--;
Vertex t = undotail[ntoggled], h = undohead[ntoggled];
double w = undoweight[ntoggled];
if(MHp->discord)
for(WtNetwork **nwd=MHp->discord; *nwd!=NULL; nwd++){
// This could be speeded up by implementing an "incrementation" function.
WtSetEdge(t, h, WtGetEdge(t, h, *nwd) + w - WtGetEdge(t, h, nwp), *nwd);
}
WtSetEdge(t, h, w, nwp);
}
}
} // step
/* Undo toggles. */
for(unsigned int i=0; i < ntoggled; i++){
Vertex t = undotail[i], h = undohead[i];
double w = undoweight[i];
if(MHp->discord)
for(WtNetwork **nwd=MHp->discord; *nwd!=NULL; nwd++){
// This could be speeded up by implementing an "incrementation" function.
WtSetEdge(t, h, WtGetEdge(t, h, *nwd) + w - WtGetEdge(t, h, nwp), *nwd);
}
WtSetEdge(t, h, w, nwp);
}
return WtMCMC_OK;
}