/*********************
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;
}
