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; }