//extern "C"
SEXP log_marg_A0k(SEXP WpostR, SEXP A0R, SEXP N2R, SEXP consttermR,
SEXP bfR, SEXP UTR, SEXP TinvR, SEXP dfR, SEXP n0R)
{
int i, j, *dTi, db, m, N2, df, len;
N2=INTEGER(N2R)[0]; df=INTEGER(dfR)[0]; m=INTEGER(coerceVector(listElt(WpostR,"m"),INTSXP))[0];
double *pbfi, *lpa0, *cterm, lN2, tol, maxvlog, lqlog;
lN2=log((double)N2); tol=1E-12; cterm=REAL(consttermR); //Rprintf("m: %d\nN2: %d\ndf: %d\n",m,N2,df);
// Initialize Tinv/b.free/vlog variables
SEXP Ti, bfi; Matrix Tinv; ColumnVector bfree, vlog(N2), qlog;
// Initialize Wlist/W/Wmat objects and populate Wlist from WpostR
Wlist Wall(WpostR,N2); Wobj W; Matrix Wmat;
// Initialize SEXP/ptr to store/access log marginal A0k values
SEXP lpa0yao; PROTECT(lpa0yao=allocVector(REALSXP,m)); lpa0=REAL(lpa0yao);
for(i=0;i<m-1;i++){
PROTECT(Ti=VECTOR_ELT(TinvR,i));
dTi=getdims(Ti); Tinv=R2Cmat(Ti,dTi[0],dTi[1]);
UNPROTECT(1); //Rprintf("Tinv[[%d]](%dx%d) initialized\n",i,dTi[0],dTi[1]);
PROTECT(bfi=VECTOR_ELT(bfR,i));
db=length(bfi); bfree.ReSize(db); pbfi=REAL(bfi); bfree<<pbfi;
UNPROTECT(1); //Rprintf("bfree[[%d]](%d) initialized\n",i,db);
for(j=1;j<=N2;j++){
Wall.getWobj(W,j); Wmat=W.getWelt(i+1); W.clear();
vlog(j)=getvlog(Wmat,Tinv,bfree,cterm[i],df,tol); //Rprintf("vlog(%d): %f\n",j,vlog(j));
}
// Modified harmonic mean of the max
maxvlog=vlog.Maximum(); qlog=vlog-maxvlog; len=qlog.Storage();
lqlog=0; for(j=1;j<=len;j++) lqlog+=exp(qlog(j)); lqlog=log(lqlog); // log(sum(exp(qlog)))
lpa0[i]=maxvlog-lN2+lqlog; //Rprintf("lpa0[%d] = %f\n", i, lpa0[i]);
}
// Computations for last column
PROTECT(Ti=VECTOR_ELT(TinvR,m-1));
dTi=getdims(Ti); Tinv=R2Cmat(Ti,dTi[0],dTi[1]);
UNPROTECT(1); //Rprintf("Tinv[[%d]](%dx%d) initialized\n",i,dTi[0],dTi[1]);
PROTECT(bfi=VECTOR_ELT(bfR,m-1));
pbfi=REAL(bfi); bfree.ReSize(length(bfi)); bfree<<pbfi;
UNPROTECT(1); //Rprintf("bfree[[%d]](%d) initialized\n",i,db);
UTobj UT(UTR); Matrix A0=R2Cmat(A0R,m,m);
A0=drawA0cpp(A0,UT,df,INTEGER(n0R),W); Wmat=W.getWelt(m);
lpa0[m-1]=getvlog(Wmat,Tinv,bfree,cterm[m-1],df,tol); //Rprintf("lpa0[%d] = %f\n",m-1,lpa0[m-1]);
// Return R object lpa0yao
UNPROTECT(1); return lpa0yao;
}
Foam
fboxNth(FoamBox fbox, int n)
{
int initArgc;
if (!fbox->initial)
initArgc = 0;
else
initArgc = foamArgc(fbox->initial) - foamNaryStart(fbox->tag);
if (n < initArgc)
return foamArgv(fbox->initial)[n + foamNaryStart(fbox->tag)].code;
else {
int i = fbox->argc - n - 1;
return listElt(Foam)(fbox->l, i);
}
}
//extern "C"
SEXP mc_irf_var(SEXP varobj, SEXP nsteps, SEXP draws)
{
int m, p, dr=INTEGER(draws)[0], ns=INTEGER(nsteps)[0], T, df, i;
SEXP AR, Y, Bhat, XR, prior, hstar, meanS, output;
// Get # vars/lags/steps/draws/T/df
PROTECT(AR = listElt(varobj, "ar.coefs"));
PROTECT(Y = listElt(varobj, "Y"));
m = INTEGER(getAttrib(AR, R_DimSymbol))[0]; //#vars
p = INTEGER(getAttrib(AR, R_DimSymbol))[2]; //#lags
T = nrows(Y); df = T - m*p - m - 1;
UNPROTECT(2);
// Put coefficients from varobj$Bhat in Bcoefs vector (m^2*p, 1)
PROTECT(Bhat = coerceVector(listElt(varobj, "Bhat"), REALSXP));
Matrix bcoefs = R2Cmat(Bhat, m*p, m);
bcoefs = bcoefs.AsColumn();
UNPROTECT(1);
// Define X(T x m*p) subset of varobj$X and XXinv as solve(X'X)
PROTECT(XR = coerceVector(listElt(varobj,"X"),REALSXP));
Matrix X = R2Cmat(XR, T, m*p), XXinv;
UNPROTECT(1);
// Get the correct moment matrix
PROTECT(prior = listElt(varobj,"prior"));
if(!isNull(prior)){
PROTECT(hstar = coerceVector(listElt(varobj,"hstar"),REALSXP));
XXinv = R2Cmat(hstar, m*p, m*p).i();
UNPROTECT(1);
}
else { XXinv = (X.t()*X).i(); }
UNPROTECT(1);
// Get the transpose of the Cholesky decomp of XXinv
SymmetricMatrix XXinvSym; XXinvSym << XXinv;
XXinv = Cholesky(XXinvSym);
// Cholesky of covariance
PROTECT(meanS = coerceVector(listElt(varobj,"mean.S"),REALSXP));
SymmetricMatrix meanSSym; meanSSym << R2Cmat(meanS, m, m);
Matrix Sigmat = Cholesky(meanSSym);
UNPROTECT(1);
// Matricies needed for the loop
ColumnVector bvec; bvec=0.0;
Matrix sqrtwish, impulse(dr,m*m*ns); impulse = 0.0;
SymmetricMatrix sigmadraw; sigmadraw = 0.0;
IdentityMatrix I(m);
GetRNGstate();
// Main Loop
for (i=1; i<=dr; i++){
// Wishart/Beta draws
sigmadraw << Sigmat*(T*rwish(I,df).i())*Sigmat.t();
sqrtwish = Cholesky(sigmadraw);
bvec = bcoefs+KP(sqrtwish, XXinv)*rnorms(m*m*p);
// IRF computation
impulse.Row(i) = irf_var_from_beta(sqrtwish, bvec, ns).t();
if (!(i%1000)){ Rprintf("Monte Carlo IRF Iteration = %d\n",i); }
} // end main loop
PutRNGstate();
int dims[]={dr,ns,m*m};
PROTECT(output = C2R3D(impulse,dims));
setclass(output,"mc.irf.VAR");
UNPROTECT(1);
return output;
}
