static int pexp7 (void) {
int ei0, ei1, ei2;
ei0 = 0;
switch (Ltok) {
case L_FUNCTION:
Lgtok ();
ei0 = pfunc ();
break;
case L_LP:
ei0 = Cnew (C_PEXPR);
Lgtok ();
ei1 = pexpr ();
GTOKIFEQ (L_RP);
Csetfp (ei0, ei1);
break;
case L_LB:
ei0 = ptcons ();
break;
case L_STRING:
case L_NUMBER:
ei0 = pcons ();
break;
case L_ID:
ei0 = pvar ();
if (Ltok == L_LP) { /* ie: it's really a function call */
ei1 = ei0;
ei0 = Cnew (C_FCALL);
Csetfp (ei0, ei1);
Lgtok ();
ei2 = pargs ();
Csetnext (ei1, ei2);
GTOKIFEQ (L_RP);
}
break;
default:
err ("expected EXP7 type token, found: %s", Lnames[Ltok]);
}
return ei0;
}
static int pexp7 (void) {
int ei0, ei1;
switch (EEltok) {
case L_LP:
if ((ei0 = EEcnew (C_PEXPR)) == -1) {
SUwarning (0, "pexp7", "cannot create code");
return -1;
}
EElgtok ();
if ((ei1 = pexpr ()) == -1) {
SUwarning (0, "pexp7", "cannot create expression");
return -1;
}
GTOKIFEQ (L_RP);
EEcsetfp (ei0, ei1);
break;
case L_STRING:
case L_NUMBER:
if ((ei0 = pcons ()) == -1) {
SUwarning (0, "pexp7", "cannot create constant expression");
return -1;
}
break;
case L_ID:
if ((ei0 = pvar ()) == -1) {
SUwarning (0, "pexp7", "cannot create variable expression");
return -1;
}
break;
default:
SUwarning (
0, "pexp7",
"unexpected token: %s, string: %s", EElnames[EEltok], EElgetstr ()
);
}
return ei0;
}
// [[Rcpp::export]]
SEXP rcpp_bcpM(SEXP pdata, SEXP pid, SEXP pmcmcreturn, SEXP pburnin, SEXP pmcmc,
SEXP pa, SEXP pw)
{
NumericMatrix data(pdata);
int mcmcreturn = INTEGER_DATA(pmcmcreturn)[0];
int burnin = INTEGER_DATA(pburnin)[0];
int mcmc = INTEGER_DATA(pmcmc)[0];
// INITIALIZATION OF LOCAL VARIABLES
int i, j, m, k;
double wstar, xmax;
// INITIALIZATION OF OTHER OBJECTS
HelperVariables helpers(data, pid);
Params params(pw, helpers.cumksize.size(), data.nrow(), pa, false, false,
0, 0, data.ncol());
//params.print();
//helpers.print();
int MM = burnin + mcmc;
//helpers.print();
//params.print();
MCMCStepSeq step(helpers, params);
int MM2, nn2;
if (mcmcreturn == 0) {
MM2 = 1;
nn2 = 1;
} else {
nn2 = params.nn;
MM2 = MM;
}
// Things to be returned to R:
NumericMatrix pmean(params.nn, params.kk);
NumericMatrix ss(params.nn, params.kk);
NumericMatrix pvar(params.nn, params.kk);
NumericVector pchange(params.nn);
NumericVector blocks(burnin + mcmc);
NumericMatrix rhos(nn2, MM2);
// NumericVector liks(MM2);
NumericMatrix results(nn2*MM2,params.kk);
double tmpMean;
// Rprintf("starting\n");
GetRNGstate(); // Consider Dirk's comment on this.
// step.print();
for (i = 0; i < params.nn; i++) {
pchange[i] = 0;
for (j = 0; j < params.kk; j++) {
pmean(i, j) = 0;
}
}
for (m = 0; m < MM; m++) {
// Rprintf("Step %d -- ", m);
step = pass(step, helpers, params);
// Rprintf("blocks:%d, B:%0.2f\n", step.b, step.B);
blocks[m] = step.b;
if (m >= burnin || mcmcreturn == 1) {
// compute posteriors
if (step.B == 0) {
wstar = params.w[0] * (step.b*params.kk + 1) / (step.b * params.kk +3);
} else {
xmax = step.B * params.w[0] / step.W / (1 + step.B * params.w[0] / step.W);
// Rprintf("xmax:%0.2f\n", xmax);
// wstar = log(step.W) - log(step.B)
// + Rf_lbeta((double) (step.b* params.kk + 3) / 2, (double) ((params.nn2 - step.b)*params.kk - 4) / 2)
// + Rf_pbeta(xmax, (double) (step.b*params.kk + 3) / 2, (double) ((params.nn2 - step.b)*params.kk - 4) / 2, 1, 1)
// - Rf_lbeta((double) (step.b*params.kk + 1) / 2, (double) ((params.nn2 - step.b)*params.kk - 2) / 2)
// - Rf_pbeta(xmax, (double) (step.b * params.kk+ 1) / 2, (double) ((params.nn2 - step.b)*params.kk - 2) / 2, 1, 1);
// wstar = exp(wstar);
wstar = (step.W/step.B)*
Rf_beta((double) (step.b* params.kk + 3) / 2, (double) ((params.nn2 - step.b)*params.kk - 4) / 2) *
Rf_pbeta(xmax, (double) (step.b*params.kk + 3) / 2, (double) ((params.nn2 - step.b)*params.kk - 4) / 2, 1, 0) /
Rf_beta((double) (step.b*params.kk + 1) / 2, (double) ((params.nn2 - step.b)*params.kk - 2) / 2) /
Rf_pbeta(xmax, (double) (step.b * params.kk+ 1) / 2, (double) ((params.nn2 - step.b)*params.kk - 2) / 2, 1, 0);
// Rprintf("wstar:%0.2f\n", wstar);
}
// for posterior estimate of overall noise variance
// if (m >= burnin)
// pvar += (step.W + wstar*step.B)/(params.nn2 * params.kk-3);
k = 0;
for (j = 0; j < params.nn; j++) {
// Rprintf("j:%d out of %d (%d, %d) | ", j, params.nn, pchange.size(), step.rho.size());
// Rprintf("pchange[%d]: %0.2f, step.rho:%d\n", j, pchange[j], step.rho[j]);
if (m >= burnin)
pchange[j] += (double) step.rho[j];
for (i = 0; i < params.kk; i++) {
tmpMean = step.bmean[k][i] * (1 - wstar) + helpers.ybar * wstar;
// Rprintf("i:%d -- tmpMean:%0.2f, wstar:%0.2f, bmean:%0.2f, ybar:%0.2f\n",
// i, tmpMean, wstar, step.bmean[k][i], helpers.ybar);
if (m >= burnin) {
pmean(j, i) += tmpMean;
ss(j, i) += tmpMean * tmpMean;
// Rprintf("pmean:%0.2f, ss:%0.2f\n", pmean(j,i), ss(j,i));
}
if (mcmcreturn == 1)
results(m*params.nn+j, i) = tmpMean;
}
if (mcmcreturn == 1)
rhos(j, m) = step.rho[j];
if (step.rho[j] == 1) k++;
}
}
}
// Rprintf("post processing\n");
// step.print();
// post processing
for (j = 0; j < params.nn; j++) {
pchange[j] /= mcmc;
for (i = 0; i < params.kk; i++) {
pmean(j, i) /= mcmc;
pvar(j, i) = (ss(j, i) / mcmc - pmean(j,i)*pmean(j,i))*(mcmc/(mcmc-1));
}
}
// Rprintf("ending\n");
PutRNGstate();
List z;
z["posterior.mean"] = pmean;
z["posterior.var"] = pvar;
z["posterior.prob"] = pchange;
z["blocks"] = blocks;
z["mcmc.rhos"] = rhos;
z["mcmc.means"] = results;
// z["lik"] = liks;
return z;
} /* END MAIN */
