int update(ENVELOPE *env, POINT *p, FUNBAG *lpdf, METROPOLIS *metrop)
/* to update envelope to incorporate new point on log density*/
/* *env : envelope attributes */
/* *p : point to be incorporated */
/* *lpdf : to evaluate log-density */
/* *metrop : for metropolis step */
{
POINT *m,*ql,*qr,*q;
if(!(p->f) || (env->cpoint > env->npoint - 2)){
/* y-value has not been evaluated or no room for further points */
/* ignore this point */
return 0;
}
/* copy working POINT p to a new POINT q */
q = env->p + env->cpoint++;
q->x = p->x;
q->y = p->y;
q->f = 1;
/* allocate an unused POINT for a new intersection */
m = env->p + env->cpoint++;
m->f = 0;
if((p->pl->f) && !(p->pr->f)){
/* left end of piece is on log density; right end is not */
/* set up new intersection in interval between p->pl and p */
m->pl = p->pl;
m->pr = q;
q->pl = m;
q->pr = p->pr;
m->pl->pr = m;
q->pr->pl = q;
} else if (!(p->pl->f) && (p->pr->f)){
/* left end of interval is not on log density; right end is */
/* set up new intersection in interval between p and p->pr */
m->pr = p->pr;
m->pl = q;
q->pr = m;
q->pl = p->pl;
m->pr->pl = m;
q->pl->pr = q;
} else {
/* this should be impossible */
exit(10);
}
/* now adjust position of q within interval if too close to an endpoint */
if(q->pl->pl != NULL){
ql = q->pl->pl;
} else {
ql = q->pl;
}
if(q->pr->pr != NULL){
qr = q->pr->pr;
} else {
qr = q->pr;
}
if (q->x < (1. - XEPS) * ql->x + XEPS * qr->x){
/* q too close to left end of interval */
q->x = (1. - XEPS) * ql->x + XEPS * qr->x;
q->y = perfunc(lpdf,env,q->x);
} else if (q->x > XEPS * ql->x + (1. - XEPS) * qr->x){
/* q too close to right end of interval */
q->x = XEPS * ql->x + (1. - XEPS) * qr->x;
q->y = perfunc(lpdf,env,q->x);
}
/* revise intersection points */
if(meet(q->pl,env,metrop)){
/* envelope violation without metropolis */
return 1;
}
if(meet(q->pr,env,metrop)){
/* envelope violation without metropolis */
return 1;
}
if(q->pl->pl != NULL){
if(meet(q->pl->pl->pl,env,metrop)){
/* envelope violation without metropolis */
return 1;
}
}
if(q->pr->pr != NULL){
if(meet(q->pr->pr->pr,env,metrop)){
/* envelope violation without metropolis */
return 1;
}
}
/* exponentiate and integrate new envelope */
cumulate(env);
return 0;
}
int test(ENVELOPE *env, POINT *p, FUNBAG *lpdf, METROPOLIS *metrop)
/* to perform rejection, squeezing, and metropolis tests */
/* *env : envelope attributes */
/* *p : point to be tested */
/* *lpdf : to evaluate log-density */
/* *metrop : data required for metropolis step */
{
double u,y,ysqueez,ynew,yold,znew,zold,w;
POINT *ql,*qr;
/* for rejection test */
u = u_random() * p->ey;
y = logshift(u,env->ymax);
if(!(metrop->on) && (p->pl->pl != NULL) && (p->pr->pr != NULL)){
/* perform squeezing test */
if(p->pl->f){
ql = p->pl;
} else {
ql = p->pl->pl;
}
if(p->pr->f){
qr = p->pr;
} else {
qr = p->pr->pr;
}
ysqueez = (qr->y * (p->x - ql->x) + ql->y * (qr->x - p->x))
/(qr->x - ql->x);
if(y <= ysqueez){
/* accept point at squeezing step */
return 1;
}
}
/* evaluate log density at point to be tested */
ynew = perfunc(lpdf,env,p->x);
/* perform rejection test */
if(!(metrop->on) || ((metrop->on) && (y >= ynew))){
/* update envelope */
p->y = ynew;
p->ey = expshift(p->y,env->ymax);
p->f = 1;
if(update(env,p,lpdf,metrop)){
/* envelope violation without metropolis */
return -1;
}
/* perform rejection test */
if(y >= ynew){
/* reject point at rejection step */
return 0;
} else {
/* accept point at rejection step */
return 1;
}
}
/* continue with metropolis step */
yold = metrop->yprev;
/* find envelope piece containing metrop->xprev */
ql = env->p;
while(ql->pl != NULL)ql = ql->pl;
while(ql->pr->x < metrop->xprev)ql = ql->pr;
qr = ql->pr;
/* calculate height of envelope at metrop->xprev */
w = (metrop->xprev - ql->x)/(qr->x - ql->x);
zold = ql->y + w*(qr->y - ql->y);
znew = p->y;
if(yold < zold)zold = yold;
if(ynew < znew)znew = ynew;
w = ynew-znew-yold+zold;
if(w > 0.0)w = 0.0;
if(w > -YCEIL){
w = exp(w);
} else {
w = 0.0;
}
u = u_random();
if(u > w){
/* metropolis says dont move, so replace current point with previous */
/* markov chain iterate */
p->x = metrop->xprev;
p->y = metrop->yprev;
p->ey = expshift(p->y,env->ymax);
p->f = 1;
p->pl = ql;
p->pr = qr;
} else {
/* trial point accepted by metropolis, so update previous markov */
/* chain iterate */
metrop->xprev = p->x;
metrop->yprev = ynew;
}
return 1;
}
int arms (double *xinit, int ninit, double *xl, double *xr,
double (*myfunc)(double x, void *mydata), void *mydata,
double *convex, int npoint, int dometrop, double *xprev, double *xsamp,
int nsamp, double *qcent, double *xcent,
int ncent, int *neval)
/* to perform derivative-free adaptive rejection sampling with metropolis step */
/* *xinit : starting values for x in ascending order */
/* ninit : number of starting values supplied */
/* *xl : left bound */
/* *xr : right bound */
/* *myfunc : function to evaluate log-density */
/* *mydata : data required by *myfunc */
/* *convex : adjustment for convexity */
/* npoint : maximum number of envelope points */
/* dometrop : whether metropolis step is required */
/* *xprev : previous value from markov chain */
/* *xsamp : to store sampled values */
/* nsamp : number of sampled values to be obtained */
/* *qcent : percentages for envelope centiles */
/* *xcent : to store requested centiles */
/* ncent : number of centiles requested */
/* *neval : on exit, the number of function evaluations performed */
{
ENVELOPE *env; /* rejection envelope */
POINT pwork; /* a working point, not yet incorporated in envelope */
int msamp=0; /* the number of x-values currently sampled */
FUNBAG lpdf; /* to hold density function and its data */
METROPOLIS *metrop; /* to hold bits for metropolis step */
int i,err;
/* check requested envelope centiles */
for(i=0; i<ncent; i++){
if((qcent[i] < 0.0) || (qcent[i] > 100.0)){
/* percentage requesting centile is out of range */
return 1005;
}
}
/* incorporate density function and its data into FUNBAG lpdf */
lpdf.mydata = mydata;
lpdf.myfunc = myfunc;
/* set up space required for envelope */
env = (ENVELOPE *)malloc(sizeof(ENVELOPE));
if(env == NULL){
/* insufficient space */
return 1006;
}
env->p = NULL;
/* start setting up metropolis struct */
metrop = (METROPOLIS *)malloc(sizeof(METROPOLIS));
if(metrop == NULL){
/* insufficient space */
free(env);
return 1006;
}
metrop->on = dometrop;
/* set up initial envelope */
err = initial(xinit,ninit,*xl,*xr,npoint,&lpdf,env,convex,
neval,metrop);
if (err) {
if ( env->p )
free(env->p);
free(env);
free(metrop);
return err;
}
/* finish setting up metropolis struct (can only do this after */
/* setting up env) */
if(metrop->on){
if((*xprev < *xl) || (*xprev > *xr)){
/* previous markov chain iterate out of range */
if( (*xprev < *xl) )
*xsamp = *xl;
if( (*xprev > *xr) )
*xsamp = *xr;
free(env->p);
free(env);
free(metrop);
return 1007;
}
metrop->xprev = *xprev;
metrop->yprev = perfunc(&lpdf,env,*xprev);
}
/* now do adaptive rejection */
do {
/* sample a new point */
sample (env,&pwork);
/* perform rejection (and perhaps metropolis) tests */
i = test(env,&pwork,&lpdf,metrop);
if(i == 1){
/* point accepted */
xsamp[msamp++] = pwork.x;
} else if (i != 0) {
/* envelope error - violation without metropolis */
free(env->p);
free(env);
free(metrop);
return 2000;
}
} while (msamp < nsamp);
/* nsamp points now sampled */
/* calculate requested envelope centiles */
for (i=0; i<ncent; i++){
invert(qcent[i]/100.0,env,&pwork);
xcent[i] = pwork.x;
}
/* free space */
free(env->p);
free(env);
free(metrop);
return 0;
}
int initial (double *xinit, int ninit, double xl, double xr, int npoint,
FUNBAG *lpdf, ENVELOPE *env, double *convex, int *neval,
METROPOLIS *metrop)
/* to set up initial envelope */
/* xinit : initial x-values */
/* ninit : number of initial x-values */
/* xl,xr : lower and upper x-bounds */
/* npoint : maximum number of POINTs allowed in envelope */
/* *lpdf : to evaluate log density */
/* *env : rejection envelope attributes */
/* *convex : adjustment for convexity */
/* *neval : current number of function evaluations */
/* *metrop : for metropolis step */
{
int i,j,k,mpoint;
POINT *q;
if(ninit<3){
/* too few initial points */
return 1001;
}
mpoint = 2*ninit + 1;
if(npoint < mpoint){
/* too many initial points */
return 1002;
}
if((xinit[0] <= xl) || (xinit[ninit-1] >= xr)){
/* initial points do not satisfy bounds */
return 1003;
}
for(i=1; i<ninit; i++){
if(xinit[i] <= xinit[i-1]){
/* data not ordered */
return 1004;
}
}
if(*convex < 0.0){
/* negative convexity parameter */
return 1008;
}
/* copy convexity address to env */
env->convex = convex;
/* copy address for current number of function evaluations */
env->neval = neval;
/* initialise current number of function evaluations */
*(env->neval) = 0;
/* set up space for envelope POINTs */
env->npoint = npoint;
env->p = (POINT *)malloc(npoint*sizeof(POINT));
if(env->p == NULL){
/* insufficient space */
return 1006;
}
/* set up envelope POINTs */
q = env->p;
/* left bound */
q->x = xl;
q->f = 0;
q->pl = NULL;
q->pr = q+1;
for(j=1, k=0; j<mpoint-1; j++){
q++;
if(j%2){
/* point on log density */
q->x = xinit[k++];
q->y = perfunc(lpdf,env,q->x);
q->f = 1;
} else {
/* intersection point */
q->f = 0;
}
q->pl = q-1;
q->pr = q+1;
}
/* right bound */
q++;
q->x = xr;
q->f = 0;
q->pl = q-1;
q->pr = NULL;
/* calculate intersection points */
q = env->p;
for (j=0; j<mpoint; j=j+2, q=q+2){
if(meet(q,env,metrop)){
/* envelope violation without metropolis */
return 2000;
}
}
/* exponentiate and integrate envelope */
cumulate(env);
/* note number of POINTs currently in envelope */
env->cpoint = mpoint;
return 0;
}
SEXP arms (SEXP bounds, SEXP myldens, SEXP yprev, SEXP size, SEXP rho) {
/* to perform derivative-free adaptive rejection sampling with metropolis step */
/* bounds : boundaries of the support of the density */
/* myldens : R function to evaluate log density */
/* yprev : previous value from markov chain */
/* size : number of sampled values to be obtained */
/* rho : R environment in which the logdensity is evaluated */
double xl, xr, xinit[NINIT], convex=1.0;
int i, npoint=100, nsamp, neval, err;
SEXP ysamp; /* sampled values */
ENVELOPE *env; /* rejection envelope */
POINT pwork; /* a working point, not yet incorporated in envelope */
int msamp=0; /* the number of x-values currently sampled */
METROPOLIS *metrop; /* to hold bits for metropolis step */
nsamp = INTEGER(size)[0];
xl = REAL(bounds)[0];
xr = REAL(bounds)[1];
for (i=0; i<NINIT; i++)
xinit[i] = xl + (i + 1.0) * (xr - xl)/(NINIT + 1.0);
PROTECT( ysamp = NEW_NUMERIC(nsamp) );
/* set up space required for envelope */
/* env = (ENVELOPE *)malloc(sizeof(ENVELOPE)); */
env = (ENVELOPE *)Calloc(1, ENVELOPE);
if(env == NULL){
/* insufficient space */
error("insufficient space");
}
/* start setting up metropolis struct */
/* metrop = (METROPOLIS *)malloc(sizeof(METROPOLIS)); */
metrop = (METROPOLIS *)Calloc(1, METROPOLIS);
if(metrop == NULL){
/* insufficient space */
error("insufficient space");
}
metrop->on = 1;
/* set up initial envelope */
err = initial(xinit,NINIT,xl,xr,npoint,myldens,env,&convex,
&neval,metrop,rho);
if(err)
error("Can set err...");
/* finish setting up metropolis struct (can only do this after */
/* setting up env) */
if(metrop->on){
if((REAL(yprev)[0] < xl) || (REAL(yprev)[0] > xr)){
/* previous markov chain iterate out of range */
error("previous markov chain iterate out of range");
}
metrop->xprev = REAL(yprev)[0];
metrop->yprev = perfunc(myldens,env,REAL(yprev)[0],rho);
}
/* now do adaptive rejection */
do {
/* sample a new point */
sample (env,&pwork);
/* perform rejection (and perhaps metropolis) tests */
i = test(env,&pwork,myldens,metrop,rho);
if(i == 1){
/* point accepted */
REAL(ysamp)[msamp++] = pwork.x;
} else if (i != 0) {
/* envelope error - violation without metropolis */
error("envelope error - violation without metropolis");
}
} while (msamp < nsamp);
/* nsamp points now sampled */
/* free space */
Free(env->p);
Free(env);
Free(metrop);
UNPROTECT(1);
return ysamp;
}
