Example #1
0
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;
}
Example #2
0
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;
}
Example #3
0
File: CbcpM.cpp Project: cran/bcp
// [[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  */