//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;
}
result_type operator()(Expr& e) const
{
const choice1_t & v1 = boost::proto::child_c<N-2>(e);
const choice2_t & v2 = boost::proto::child_c<N-1>(e);
typedef typename nt2::meta::is_integral<choice1_t>::type c_t;
std::size_t dim1 = 2, dim2 = 1;
getdims(boost::proto::child_c<1>(e), v1, v2, dim1, dim2, c_t());
result_type sizee = boost::proto::child_c<0>(e).extent();
sizee[dim1-1] = numel(boost::proto::child_c<1>(e));
sizee[dim2-1] = numel(boost::proto::child_c<2>(e));
return sizee;
}
int main(int argc, char ** argv)
{
int k;
int nfft[32];
int ndims = 1;
int isinverse = 0;
int numffts = 1000, i;
kiss_fft_cpx * buf;
kiss_fft_cpx * bufout;
int real = 0;
nfft[0] = 1024;// default
while (1) {
int c = getopt(argc, argv, "n:ix:r");
if (c == -1)
break;
switch (c) {
case 'r':
real = 1;
break;
case 'n':
ndims = getdims(nfft, optarg);
if (nfft[0] != kiss_fft_next_fast_size(nfft[0])) {
int ng = kiss_fft_next_fast_size(nfft[0]);
fprintf(stderr, "warning: %d might be a better choice for speed than %d\n", ng, nfft[0]);
}
break;
case 'x':
numffts = atoi(optarg);
break;
case 'i':
isinverse = 1;
break;
}
}
int nbytes = sizeof(kiss_fft_cpx);
for (k = 0; k < ndims; ++k)
nbytes *= nfft[k];
#ifdef USE_SIMD
numffts /= 4;
fprintf(stderr, "since SIMD implementation does 4 ffts at a time, numffts is being reduced to %d\n", numffts);
#endif
buf = (kiss_fft_cpx*)KISS_FFT_MALLOC(nbytes);
bufout = (kiss_fft_cpx*)KISS_FFT_MALLOC(nbytes);
memset(buf, 0, nbytes);
pstats_init();
if (ndims == 1) {
if (real) {
kiss_fftr_cfg st = kiss_fftr_alloc(nfft[0] , isinverse , 0, 0);
if (isinverse)
for (i = 0; i < numffts; ++i)
kiss_fftri(st , (kiss_fft_cpx*)buf, (kiss_fft_scalar*)bufout);
else
for (i = 0; i < numffts; ++i)
kiss_fftr(st , (kiss_fft_scalar*)buf, (kiss_fft_cpx*)bufout);
free(st);
} else {
kiss_fft_cfg st = kiss_fft_alloc(nfft[0] , isinverse , 0, 0);
for (i = 0; i < numffts; ++i)
kiss_fft(st , buf, bufout);
free(st);
}
} else {
if (real) {
kiss_fftndr_cfg st = kiss_fftndr_alloc(nfft, ndims , isinverse , 0, 0);
if (isinverse)
for (i = 0; i < numffts; ++i)
kiss_fftndri(st , (kiss_fft_cpx*)buf, (kiss_fft_scalar*)bufout);
else
for (i = 0; i < numffts; ++i)
kiss_fftndr(st , (kiss_fft_scalar*)buf, (kiss_fft_cpx*)bufout);
free(st);
} else {
kiss_fftnd_cfg st = kiss_fftnd_alloc(nfft, ndims, isinverse , 0, 0);
for (i = 0; i < numffts; ++i)
kiss_fftnd(st , buf, bufout);
free(st);
}
}
free(buf); free(bufout);
fprintf(stderr, "KISS\tnfft=");
for (k = 0; k < ndims; ++k)
fprintf(stderr, "%d,", nfft[k]);
fprintf(stderr, "\tnumffts=%d\n" , numffts);
pstats_report();
kiss_fft_cleanup();
return 0;
}
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;
}
