Rational-Inattention-Discrete-Choice / Section_4 / rmnlIndepMetrop_rcpp_loop_mod.cpp
rmnlIndepMetrop_rcpp_loop_mod.cpp
Raw
#include "RcppArmadillo.h" //Indicates shared library (aka package in R terms).
using namespace arma;      //Needed to avoid interference between libraries.
using namespace Rcpp;

// [[Rcpp::depends(RcppArmadillo)]] 



//including necessary CPP(!) functions from bayesm package

//timing functions
time_t itime;
char buf[100];

void startMcmcTimer() {
  itime = time(NULL);
  Rcout << " MCMC Iteration (est time to end - min) \n";
}

void infoMcmcTimer(int rep, int R) {
  time_t ctime = time(NULL);    
  char buf[32];
  
  double timetoend = difftime(ctime, itime) / 60.0 * (R - rep - 1) / (rep+1);
  sprintf(buf, " %d (%.1f)\n", rep+1, timetoend);
  Rcout <<  buf;
}

void endMcmcTimer() {
  time_t ctime = time(NULL);
  char buf[32];
  
  sprintf(buf, " Total Time Elapsed: %.2f \n", difftime(ctime, itime) / 60.0);     
  Rcout << buf;
  
  itime = 0;
}

//function to draw from mv student t distribution
//[[Rcpp::export]]
vec rmvst(double nu, vec const& mu, mat const& root){
  
  //  nu df, mean mu, Sigma=t(root)%*%root
  //  root is upper triangular cholesky root
  
  vec rnormd = rnorm(mu.size());
  vec nvec = trans(root)*rnormd;
  
  return(nvec/sqrt(rchisq(1,nu)[0]/nu) + mu); //rchisq returns a vectorized object, so using [0] allows for the conversion to double
}

//function to compute log likelihood of MNL
//[[Rcpp::export]]
double llmnl(vec const& beta, vec const& y, mat const& X){
  
  
  int n = y.size();
  int j = X.n_rows/n;
  mat Xbeta = X*beta;
  
  vec xby = zeros<vec>(n);
  vec denom = zeros<vec>(n);
  
  for(int i = 0; i<n;i++){      
    for(int p=0;p<j;p++) denom[i]=denom[i]+exp(Xbeta[i*j+p]);
    xby[i] = Xbeta[i*j+y[i]-1];
  }
  
  return(sum(xby - log(denom)));
}

//compute log density of mv normal distribution
//[[Rcpp::export]]
double lndMvn(vec const& x, vec const& mu, mat const& rooti){
  
  // mean mu, var Sigma
  // Sigma=t(root)%*%root   (root is upper tri cholesky root)
  // Sigma^-1=rooti%*%t(rooti)   
  // rooti is in the inverse of upper triangular chol root of sigma
  //          note: this is the UL decomp of sigmai not LU!
  //                Sigma=root'root   root=inv(rooti)
  
  vec z = vectorise(trans(rooti)*(x-mu));
  
  return((-(x.size()/2.0)*log(2*M_PI) -.5*(trans(z)*z) + sum(log(diagvec(rooti))))[0]);
}


//compute log density of mv student t distribution
//[[Rcpp::export]]
double lndMvst(vec const& x, double nu, vec const& mu, mat const& rooti, bool NORMC = false){
  
  
  // nu df, mean mu,
  // and with sigmai=rooti%*%t(rooti)   note: this is the UL decomp of sigmai not LU!
  // rooti is in the inverse of upper triangular chol root of sigma
  // or Sigma=root'root   root=inv(rooti)
  
  int dim = x.size();
  double constant;
  
  if(NORMC){
    constant = (nu/2)*log(nu)+lgamma((nu+dim)/2)-(dim/2.0)*log(M_PI)-lgamma(nu/2);
  } else {
    constant = 0.0;
  }
  
  vec z = vectorise(trans(rooti)*(x-mu));
  
  return((constant-((dim+nu)/2)*log(nu+trans(z)*z)+sum(log(diagvec(rooti))))[0]);
}


//Main loop function to be exported to R environment
//[[Rcpp::export]]
List rmnlIndepMetrop_rcpp_loop_mod(int R, int keep, double nu,
                                vec const& betastar, mat const& root,vec const& y,mat const& X,
                                vec const& betabar,mat const& rootpi,mat const& rooti,
                                double oldlimp,double oldlpost,int nprint) {

// Wayne Taylor 9/7/2014

  int mkeep = 0;
  int naccept = 0;    
  int ncolX = X.n_cols;
  
  mat betadraw(R/keep, ncolX);
  vec loglike(R/keep);
  vec betac = zeros<vec>(ncolX);
  rowvec beta = zeros<rowvec>(ncolX);
  double cloglike, clpost, climp, ldiff, alpha, unif, oldloglike;
  vec alphaminv;
  
  if(nprint>0) startMcmcTimer();
  
  // start main iteration loop
  for(int rep = 0; rep<R; rep++) {
    
    //propose new beta from multivariate student t, where betastar and root are
    //determined from tuning step (max log mnl likelihood)
    betac = rmvst(nu,betastar,root);
    
    //compute likelihood and posterior
    cloglike = llmnl(betac,y,X);
    clpost = cloglike+lndMvn(betac,betabar,rootpi);
    
    //compute acceptance probability
    climp = lndMvst(betac,nu,betastar,rooti,false);
    ldiff = clpost+oldlimp-oldlpost-climp;
    alphaminv << 1 << exp(ldiff); //intializes variables in the alphaminv vec: c(1,exp(ldiff))
    alpha = min(alphaminv);
  
    if(alpha < 1.0) {
        unif = runif(1)[0]; //rnorm returns a NumericVector, so using [0] allows for conversion to double
      }else{
        unif = 0.0;
      }
    if (unif <= alpha){ 
      beta = trans(betac);
      oldloglike = cloglike;
      oldlpost = clpost;
      oldlimp = climp;
      naccept++;
    }
          
    if (nprint>0) if ((rep+1)%nprint==0) infoMcmcTimer(rep, R);
    
    if((rep+1)%keep==0){
      mkeep = (rep+1)/keep;
      betadraw(mkeep-1,span::all) = beta;
      loglike[mkeep-1] = oldloglike;
    }
  }
  
  if(nprint>0) endMcmcTimer();
      
  return List::create(
    Named("betadraw") = betadraw, 
    Named("loglike") = loglike, 
    Named("naccept") = naccept);
}