SEXP msbsvar_irf(SEXP gibbs, SEXP msbsvar, SEXP nsteps)
{
int i, k, n, N2, h, m, p, n0max, ns=INTEGER(nsteps)[0];
int *db, *dF, *dxi, *dQ, N210pct, pctct=0;
SEXP bR, FR, xiR, QR, Ui, IRFlist, IRFtmp;
// Rprintf("ns = %d\n",ns);
// Get b, F, xi, Q, SS, dims from gibbs object
PROTECT(bR = VECTOR_ELT(gibbs,0)); db=getdims(bR);
// Rprintf("b(%d,%d)\n",db[0],db[1]);
PROTECT(FR = VECTOR_ELT(gibbs,1)); dF=getdims(FR);
// Rprintf("F(%d,%d)\n",dF[0],dF[1]);
PROTECT(xiR= VECTOR_ELT(gibbs,2)); dxi=getdims(xiR);
// Rprintf("xi(%d,%d)\n",dxi[0],dxi[1]);
PROTECT(QR = VECTOR_ELT(gibbs,3)); dQ=getdims(QR); UNPROTECT(1);
// Rprintf("Q(%d,%d)\n",dQ[0],dQ[1]);
// Rprintf("Gibbs Objects and Dimensions Assigned\n");
// Reconstruct constants
N2=db[0]; h=(int)sqrt((double)dQ[1]); n0max=db[1]/h; m=dxi[1]/h; p=((dF[1]/(h*m))-1)/m;
N210pct=N2/10;
// Rprintf("N2=%d\nh=%d\nm=%d\np=%d\nn0max=%d\n",N2,h,m,p,n0max);
// Get Ui from msbsvar
PROTECT(Ui=VECTOR_ELT(msbsvar,7));
Matrix bsample=R2Cmat(bR,N2,n0max*h);
Matrix Fsample=R2Cmat(FR,N2,m*(m*p+1)*h);
Matrix xisample=R2Cmat(xiR,N2,m*h);
ColumnVector bk(n0max), Fk(m*(m*p+1)), bvec(m*m*p); bk=0.0; Fk=0.0; bvec=0.0;
DiagonalMatrix xik(m), sqrtxik(m); xik=0.0; sqrtxik=0.0;
Matrix Q(h,h), A0(m,m), A0i(m,m), fmat(m,m*p+1), sqrtwish, impulse(N2,m*m*ns);
double *pFk; int IRFdims[]={N2,ns,m*m};
PROTECT(IRFlist=allocVector(VECSXP,h));
// Loop over regimes
for(k=1;k<=h;k++){
// Rprintf("\n==========\nRegime %d\n==========\n",k);
pctct=0;
// Compute impulse responses for every draw of regime k
for(n=1;n<=N2;n++){
// Rprintf("\nDraw %d:\n",n);
// Get values for draw 'n', regime 'k'
bk=bsample.SubMatrix(n,n,(k-1)*n0max+1,k*n0max).t();
// Rprintf("--bk(%d): ",bk.Storage()); //printCVector(bk);
Fk=Fsample.SubMatrix(n,n,(k-1)*m*(m*p+1)+1,k*m*(m*p+1)).t(); pFk=Fk.Store();
// Rprintf("--Fk(%d): ",Fk.Storage()); //printCVector(Fk);
for(i=1;i<=m;i++) xik(i)=sqrt(xisample(n,(k-1)*m+i));
// Rprintf("--xik(%d)/sqrtxik(%d) defined\n",m,m);
// Compute A0/A0^-1/sqrtwish for regime k
A0=b2a(bk,Ui);
//Rprintf("--A0(%d,%d):",m,m); //printMatrix(A0);
A0i=A0.i();
//Rprintf("--A0^-1(%d,%d):",m,m); //printMatrix(A0i);
sqrtwish=(A0*xik).i();
//Rprintf("--sqrtwish(%d,%d):",m,m); //printMatrix(sqrtwish);
// Compute beta vector
fmat.ReSize(m,m*p+1); fmat<<pFk; fmat=fmat.t();
fmat=(fmat.Rows(1,m*p)*A0i).t(); bvec=fmat.AsColumn();
// Rprintf("--fmat(%d,%d):",m,m*p+1); printMatrix(fmat);
// Rprintf("bvec_%d:", n); printCVector(bvec);
// Compute IRF
impulse.Row(n)=irf_var_from_beta(sqrtwish.t(), bvec, ns).t();
if (!(n%N210pct))
Rprintf("Regime %d: Monte Carlo IRF %d percent complete (Iteration %d)\n",k,++pctct*10,n);
}
// Create and class Robj for impulses, load into IRFlist
PROTECT(IRFtmp=C2R3D(impulse,IRFdims));
setclass(IRFtmp,"mc.irf.BSVAR"); SET_VECTOR_ELT(IRFlist, k-1, IRFtmp);
UNPROTECT(1);
}
UNPROTECT(5);
return IRFlist;
}
/*
* The out of control system call
* This is audit kitchen sink aka auditadm, aka auditon
*/
int
auditctl(
int cmd,
caddr_t data,
int length)
{
int result;
switch (cmd) {
case A_GETAMASK:
case A_GETCOND:
case A_GETCAR:
case A_GETCLASS:
case A_GETCWD:
case A_GETKAUDIT:
case A_GETKMASK:
case A_GETPINFO:
case A_GETPINFO_ADDR:
case A_GETPOLICY:
case A_GETQCTRL:
case A_GETSTAT:
if (secpolicy_audit_getattr(CRED(), B_FALSE) != 0)
return (EPERM);
break;
default:
if (secpolicy_audit_config(CRED()) != 0)
return (EPERM);
break;
}
switch (cmd) {
case A_GETPOLICY:
result = getpolicy(data);
break;
case A_SETPOLICY:
result = setpolicy(data);
break;
case A_GETAMASK:
result = getamask(data);
break;
case A_SETAMASK:
result = setamask(data);
break;
case A_GETKMASK:
result = getkmask(data);
break;
case A_SETKMASK:
result = setkmask(data);
break;
case A_GETKAUDIT:
result = getkaudit(data, length);
break;
case A_SETKAUDIT:
result = setkaudit(data, length);
break;
case A_GETQCTRL:
result = getqctrl(data);
break;
case A_SETQCTRL:
result = setqctrl(data);
break;
case A_GETCWD:
result = getcwd(data, length);
break;
case A_GETCAR:
result = getcar(data, length);
break;
case A_GETSTAT:
result = getstat(data);
break;
case A_SETSTAT:
result = setstat(data);
break;
case A_SETUMASK:
result = setumask(data);
break;
case A_SETSMASK:
result = setsmask(data);
break;
case A_GETCOND:
result = getcond(data);
break;
case A_SETCOND:
result = setcond(data);
break;
case A_GETCLASS:
result = getclass(data);
break;
case A_SETCLASS:
result = setclass(data);
break;
case A_GETPINFO:
result = getpinfo(data);
break;
case A_GETPINFO_ADDR:
result = getpinfo_addr(data, length);
break;
case A_SETPMASK:
result = setpmask(data);
break;
default:
result = EINVAL;
break;
}
return (result);
}
//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;
}
