void GeneralizedEigenSystemSolverRealSymmetricMatrices(const Array2 < doublevar > & Ain, const Array2 < doublevar> & Bin, Array1 < doublevar> & evals, Array2 < doublevar> & evecs){
//solves generalized eigensystem problem A.x=labda*B.x
//returns eigenvalues from largest to lowest and
//eigenvectors, where for i-th eigenvalue, the eigenvector components are evecs(*,i)
//eigenvectors are normalized such that: evecs**T*B*evecs = I;
#ifdef USE_LAPACK //if LAPACK
int N=Ain.dim[0];
/* allocate and initialise the matrix */
Array2 <doublevar> A_temp(N,N), B_temp(N,N);
Array1 <doublevar> W,WORK;
/* allocate space for the output parameters and workspace arrays */
W.Resize(N);
A_temp=Ain;
B_temp=Bin;
int info;
int NB=64;
int NMAX=N;
int lda=NMAX;
int ldb=NMAX;
int LWORK=(NB+2)*NMAX;
WORK.Resize(LWORK);
/* get the eigenvalues and eigenvectors */
info=dsygv(1, 'V', 'U' , N, A_temp.v, lda, B_temp.v, ldb, W.v, WORK.v, LWORK);
if(info>0)
error("Internal error in the LAPACK routine dsyevr");
if(info<0)
error("Problem with the input parameter of LAPACK routine dsyevr in position "-info);
for (int i=0; i<N; i++)
evals(i)=W[N-1-i];
for (int i=0; i<N; i++) {
for (int j=0; j<N; j++) {
evecs(j,i)=A_temp(N-1-i,j);
}
}
//END OF LAPACK
#else //IF NO LAPACK
//for now we will solve it only approximatively
int N=Ain.dim[0];
Array2 <doublevar> B_inverse(N,N),A_renorm(N,N);
InvertMatrix(Bin,B_inverse,N);
MultiplyMatrices(B_inverse,Ain,A_renorm,N);
//note A_renorm is not explicitly symmetric
EigenSystemSolverRealSymmetricMatrix(A_renorm,evals,evecs);
#endif //END OF NO LAPACK
}
RcppExport SEXP nniv(SEXP arg1, SEXP arg2, SEXP arg3) {
// 3 arguments
// arg1 for parameters
// arg2 for data
// arg3 for Gibbs
// data
List list2(arg2);
const MatrixXd X=as< Map<MatrixXd> >(list2["X"]),
Z=as< Map<MatrixXd> >(list2["Z"]);
const VectorXd t=as< Map<VectorXd> >(list2["t"]),
y=as< Map<VectorXd> >(list2["y"]);
const int N=X.rows(), p=X.cols(), q=Z.cols(), r=p+q, s=p+r;
// parameters
List list1(arg1),
beta_info=list1["beta"],
Tprec_info=list1["Tprec"],
mu_info=list1["mu"],
theta_info=list1["theta"];
// prior parameters
List beta_prior=beta_info["prior"],
Tprec_prior=Tprec_info["prior"],
mu_prior=mu_info["prior"],
theta_prior=theta_info["prior"];
const double Tprec_prior_nu=as<double>(Tprec_prior["nu"]);
const Matrix2d Tprec_prior_Psi=as< Map<MatrixXd> >(Tprec_prior["Psi"]);
const double beta_prior_mean=as<double>(beta_prior["mean"]);
const double beta_prior_prec=as<double>(beta_prior["prec"]);
const Vector2d mu_prior_mean=as< Map<VectorXd> >(mu_prior["mean"]);
const Matrix2d mu_prior_prec=as< Map<MatrixXd> >(mu_prior["prec"]);
const VectorXd theta_prior_mean=as< Map<VectorXd> >(theta_prior["mean"]);
const MatrixXd theta_prior_prec=as< Map<MatrixXd> >(theta_prior["prec"]);
// initialize parameters
double beta=as<double>(beta_info["init"]);
Matrix2d Tprec=as< Map<MatrixXd> >(Tprec_info["init"]);
Vector2d mu =as< Map<VectorXd> >(mu_info["init"]);
VectorXd theta=as< Map<VectorXd> >(theta_info["init"]);
// Gibbs
List list3(arg3); //, save=list3["save"];
const int burnin=as<int>(list3["burnin"]), M=as<int>(list3["M"]),
thin=as<int>(list3["thin"]), m=7+s;
MatrixXd GS(M, m);
// prior parameter intermediate values
double beta_prior_prod=beta_prior_prec * beta_prior_mean;
VectorXd theta_prior_prod=theta_prior_prec * theta_prior_mean;
Vector2d mu_prior_prod=mu_prior_prec*mu_prior_mean;
// parameter intermediate values
Matrix2d Sigma, B_inverse;
Sigma=Tprec.inverse();
B_inverse.setIdentity();
VectorXd gamma=theta.segment(0, p),
delta=theta.segment(p, q),
eta =theta.segment(r, p);
/*
MatrixXd Theta(2, r);
Theta.row(0)=theta.segment(0, r);
Theta.bottomLeftCorner(1, q)=RowVectorXd::Zero(q);
Theta.bottomRightCorner(1, p)=eta.transpose();
*/
Vector2d eps, eps_sum;
MatrixXd D(N, 2), theta_cond_var_root(s, s), W(2, s);
W.setZero();
MatrixXd theta_cond_prec(s, s);
VectorXd theta_cond_prod(s), w(r);
Matrix2d mu_cond_prec, mu_cond_var_root, E;
Vector2d u, R, mu_cond_prod, mu_u;
double beta_scale, beta_prec, beta_prod, beta_cond_var, beta_cond_mean;
int h=0, i, l;
// Gibbs loop
//for(int l=-burnin; l<=(M-1)*thin; ++l) {
l=-burnin;
do{
// sample beta
D.col(0).setConstant(-mu[0]);
D.col(1).setConstant(-mu[1]);
D.col(0) += (t - X*gamma - Z*delta);
D.col(1) += (y - X*eta);
beta_scale=1./(Sigma(0, 0)*t.dot(t));
beta_prec=1./(beta_scale*Sigma.determinant());
beta_prod=beta_prec*beta_scale
*((Sigma(0, 0)*D.col(1)-Sigma(0, 1)*D.col(0)).array()*t.array()).sum();
beta_cond_var=1./(beta_prec+beta_prior_prec);
beta_cond_mean=beta_cond_var*(beta_prod+beta_prior_prod);
beta=rnorm1d(beta_cond_mean, sqrt(beta_cond_var));
B_inverse(1, 0)=-beta;
// sample theta
theta_cond_prec=theta_prior_prec;
theta_cond_prod=theta_prior_prod;
for(i=0; i<N; ++i) {
/*
W.topLeftCorner(1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.bottomRightCorner(1, p)=X.row(i);
*/
W.block(0, 0, 1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.block(1, r, 1, p)=X.row(i);
theta_cond_prec += (W.transpose() * Tprec * W);
u[0]=t[i];
u[1]=y[i];
R=B_inverse*u-mu;
theta_cond_prod += (W.transpose() * Tprec * R);
}
theta_cond_var_root=inv_root_chol(theta_cond_prec);
// theta_cond_var_root=inv_root_svd(theta_cond_prec); // for validation only
theta=theta_cond_var_root*(rnormXd(s)+theta_cond_var_root.transpose()*theta_cond_prod);
gamma=theta.segment(0, p);
delta=theta.segment(p, q);
eta =theta.segment(r, p);
/*
Theta.topRows(1)=theta.segment(0, r).transpose();
Theta.bottomRightCorner(1, p)=eta.transpose();
*/
// sample mu
eps_sum.setZero();
//W.setZero();
E.setZero();
for(i=0; i<N; ++i) {
/*
W.topLeftCorner(1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.bottomRightCorner(1, p)=X.row(i);
*/
W.block(0, 0, 1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.block(1, r, 1, p)=X.row(i);
/*
w.segment(0, q)=Z.row(i);
w.segment(q, p)=X.row(i);
*/
u[0]=t[i];
u[1]=y[i];
//eps += B_inverse*u - Theta*w;
eps = B_inverse*u - W*theta;
eps_sum += eps;
eps -= mu;
E += eps*eps.transpose();
}
mu_cond_prod=Tprec*eps_sum+mu_prior_prod;
mu_cond_prec=(N*Tprec+mu_prior_prec);
mu_cond_var_root=inv_root_chol(mu_cond_prec);
// mu_cond_var_root=inv_root_svd(mu_cond_prec); // for validation only
mu=mu_cond_var_root*(rnormXd(2)+mu_cond_var_root.transpose()*mu_cond_prod);
// sample Tprec
Tprec = rwishart((E+Tprec_prior_Psi).inverse(), N+Tprec_prior_nu);
Sigma = Tprec.inverse();
if(l>=0 && l%thin == 0) {
h = (l/thin);
GS.block(h, 0, 1, s)=theta.transpose();
GS(h, s)=beta;
GS(h, s+1)=mu[0];
GS(h, s+2)=mu[1];
GS(h, s+3)=Tprec(0, 0);
GS(h, s+4)=Tprec(0, 1);
GS(h, s+5)=Tprec(0, 1);
GS(h, s+6)=Tprec(1, 1);
}
l++;
} while (l<=(M-1)*thin && beta==beta);
if(beta != beta) GS.conservativeResize(h+1, m);
return wrap(GS);
}
RcppExport SEXP bbivDPM(SEXP arg1, SEXP arg2, SEXP arg3) {
// 3 arguments
// arg1 for parameters
// arg2 for data
// arg3 for Gibbs
// data
List list2(arg2);
const MatrixXd X=as< Map<MatrixXd> >(list2["X"]),
Z=as< Map<MatrixXd> >(list2["Z"]);
const VectorXi v1=as< Map<VectorXi> >(list2["tbin"]),
v2=as< Map<VectorXi> >(list2["ybin"]);
const int N=X.rows(), p=X.cols(), q=Z.cols(), r=p+q, s=p+r;
#ifdef DEBUG_NEAL8
List P, Phi, B;
VectorXi S, one;
one.setConstant(N, 1);
#endif
// parameters
List list1(arg1),
beta_info=list1["beta"],
rho_info=list1["rho"],
mu_info=list1["mu"],
theta_info=list1["theta"],
dpm_info=list1["dpm"], // DPM
alpha_info=dpm_info["alpha"], // alpha random
alpha_prior; // alpha random
const int m=as<int>(dpm_info["m"]); // DPM
// const double alpha=as<double>(dpm_info["alpha"]); // DPM
const int alpha_fixed=as<int>(alpha_info["fixed"]); // alpha random
double alpha=as<double>(alpha_info["init"]); // alpha random
if(alpha_fixed==0) alpha_prior=alpha_info["prior"]; // alpha random
VectorXi C=as< Map<VectorXi> >(dpm_info["C"]),
states=as< Map<VectorXi> >(dpm_info["states"]);
/* checks done in neal8
if(states.sum()!=N || C.size()!=N) { // limited reality check of C and states
C.setConstant(N, 0);
states.setConstant(1, N);
}
*/
// prior parameters
List beta_prior=beta_info["prior"],
// no prior parameters for rho
dpm_prior=dpm_info["prior"],
theta_prior=theta_info["prior"];
const double beta_prior_mean=as<double>(beta_prior["mean"]);
const double beta_prior_prec=as<double>(beta_prior["prec"]);
const VectorXd theta_prior_mean=as< Map<VectorXd> >(theta_prior["mean"]);
const MatrixXd theta_prior_prec=as< Map<MatrixXd> >(theta_prior["prec"]);
// initialize parameters
double beta =as<double>(beta_info["init"]);
double rho_init=as<double>(rho_info["init"]); // DPM
//int rho_MH =as<int>(rho_info["MH"]);
Vector2d mu_init=as< Map<VectorXd> >(mu_info["init"]); // DPM
VectorXd theta =as< Map<VectorXd> >(theta_info["init"]);
VectorXd rho(N); // DPM
/*
VectorXi C, states; // DPM
C.setConstant(N, 0); // DPM
states.setConstant(1, N); // DPM
*/
MatrixXd mu(N, 2), phi(1, 3); // DPM
phi(0, 0)=mu_init[0]; // DPM
phi(0, 1)=mu_init[1]; // DPM
phi(0, 2)=rho_init; // DPM
// Gibbs
List list3(arg3);
const int burnin=as<int>(list3["burnin"]), M=as<int>(list3["M"]),
thin=as<int>(list3["thin"]);
VectorXi quadrant(N);
VectorXd t(N), y(N); // latents
// prior parameter intermediate values
double beta_prior_prod=beta_prior_prec * beta_prior_mean;
VectorXd theta_prior_prod=theta_prior_prec * theta_prior_mean;
Matrix2d Sigma, Tprec, B_inverse;
B_inverse.setIdentity();
VectorXd gamma=theta.segment(0, p),
delta=theta.segment(p, q),
eta =theta.segment(r, p);
MatrixXd eps(N, 2), D(N, 2), theta_cond_var_root(s, s), W(2, s), A(N, r+4); // DPM semi
W.setZero();
MatrixXd theta_cond_prec(s, s);
VectorXd theta_cond_prod(s), w(r), mu_t(N), mu_y(N), sd_y(N);
Vector2d u, R, mu_u; // DPM
double beta_prec, beta_prod, beta_cond_var, beta_cond_mean, beta2; // DPM
int h=0, i, l;
List GS(M); //DPM
// assign quadrants
for(i=0; i<N; ++i) {
if(v1[i]==0 && v2[i]==0) quadrant[i] = 3;
else if(v1[i]==0 && v2[i]==1) quadrant[i] = 2;
else if(v1[i]==1 && v2[i]==0) quadrant[i] = 4;
else if(v1[i]==1 && v2[i]==1) quadrant[i] = 1;
}
// Gibbs loop
//for(int l=-burnin; l<=(M-1)*thin; ++l) {
l=-burnin;
do{
// populate mu/rho //DPM
for(i=0; i<N; ++i) {
mu(i, 0)=phi(C[i], 0);
mu(i, 1)=phi(C[i], 1);
rho[i]=phi(C[i], 2);
mu_t[i]=mu(i, 0);
mu_y[i]=mu(i, 1);
}
// generate latents
// mu_t = mu.col(0); //DPM
mu_t += (Z*delta + X*gamma);
// mu_y = mu.col(1); //DPM
mu_y += (beta*mu_t + X*eta);
beta2=pow(beta, 2.);
for(i=0; i<N; ++i) {
sd_y[i] = sqrt(beta2+2.*beta*rho[i]+1.); //DPM
mu_u[0]=mu_t[i];
mu_u[1]=mu_y[i]/sd_y[i]; //DPM
// z, quadrant, rho, burnin
u=rbvtruncnorm(mu_u, quadrant[i], (beta+rho[i])/sd_y[i], 10);
t[i]=u[0];
y[i]=sd_y[i]*u[1];
}
// sample beta
D.col(0) = (t - mu.col(0) - X*gamma - Z*delta); //DPM
D.col(1) = (y - mu.col(1) - X*eta); //DPM
beta_prec=0.;
beta_prod=0.;
for(i=0; i<N; ++i) {
double Sigma_det=1.-pow(rho[i], 2.); //DPM
beta_prec += pow(t[i], 2.)/Sigma_det; //DPM
beta_prod += -t[i]*(rho[i]*D(i, 0)-D(i, 1))/Sigma_det; //DPM
}
beta_cond_var=1./(beta_prec+beta_prior_prec);
beta_cond_mean=beta_cond_var*(beta_prod+beta_prior_prod);
beta=rnorm1d(beta_cond_mean, sqrt(beta_cond_var));
B_inverse(1, 0)=-beta;
// sample theta
theta_cond_prec=theta_prior_prec;
theta_cond_prod=theta_prior_prod;
for(i=0; i<N; ++i) {
double Sigma_det=1.-pow(rho[i], 2.); //DPM
Tprec(0, 0)=1./Sigma_det; Tprec(0, 1)=-rho[i]/Sigma_det; //DPM
Tprec(1, 0)=-rho[i]/Sigma_det; Tprec(1, 1)=1./Sigma_det; //DPM
mu_u[0]=mu(i, 0); //DPM
mu_u[1]=mu(i, 1); //DPM
W.block(0, 0, 1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.block(1, r, 1, p)=X.row(i);
theta_cond_prec += (W.transpose() * Tprec * W);
u[0]=t[i];
u[1]=y[i];
R=B_inverse*u-mu_u; //DPM
theta_cond_prod += (W.transpose() * Tprec * R);
}
theta_cond_var_root=inv_root_chol(theta_cond_prec);
theta=theta_cond_var_root*(rnormXd(s)+theta_cond_var_root.transpose()*theta_cond_prod);
gamma=theta.segment(0, p);
delta=theta.segment(p, q);
eta =theta.segment(r, p);
// sample mu and rho
// this for block should be placed in P0
// however, to keep changes minimal, we keep it here
for(i=0; i<N; ++i) {
W.block(0, 0, 1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.block(1, r, 1, p)=X.row(i);
u[0]=t[i];
u[1]=y[i];
eps.row(i) = (B_inverse*u - W*theta).transpose(); //DPM
}
/* semi block begins */
A.block(0, 0, N, 2)=eps;
A.col(2)=t;
A.col(3)=y;
A.block(0, 4, N, p)=X;
A.block(0, p+4, N, q)=Z;
List psi=List::create(Named("mu0")=as< Map<VectorXd> >(dpm_prior["mu0"]),
Named("T0")=as< Map<MatrixXd> >(dpm_prior["T0"]),
Named("S0")=as< Map<MatrixXd> >(dpm_prior["S0"]),
Named("beta")=beta,
Named("gamma")=gamma,
Named("delta")=delta,
Named("eta")=eta);
if(alpha_fixed==0)
alpha=bbiv_alpha(states.size(), N, alpha, alpha_prior); // alpha random
List dpm_step=neal8(A, C, phi, states, m, alpha, psi,
&bbivF, &bbivG0, &bbivP0);
/* semi block end */
/*
C=as< Map<VectorXi> >(dpm_step[0]);
phi=as< Map<MatrixXd> >(dpm_step[1]);
states=as< Map<VectorXi> >(dpm_step[2]);
*/
C=as< Map<VectorXi> >(dpm_step["C"]);
phi=as< Map<MatrixXd> >(dpm_step["phi"]);
states=as< Map<VectorXi> >(dpm_step["states"]);
#ifdef DEBUG_NEAL8
S=as< Map<VectorXi> >(dpm_step["S"]);
P=dpm_step["P"];
Phi=dpm_step["Phi"];
B=dpm_step["B"];
#endif
if(l>=0 && l%thin == 0) {
h = (l/thin);
#ifdef DEBUG_NEAL8
GS[h]=List::create(Named("beta")=beta, Named("theta")=theta,
Named("C")=C+one, Named("phi")=phi,
Named("states")=states, Named("alpha")=alpha,
Named("S")=S+one, Named("P")=P,
Named("Phi")=Phi, Named("B")=B);
#else
if(alpha_fixed==0) // alpha random
GS[h]=List::create(Named("beta")=beta, Named("theta")=theta,
Named("C")=C, Named("phi")=phi,
Named("states")=states, Named("alpha")=alpha);
else GS[h]=List::create(Named("beta")=beta, Named("theta")=theta,
Named("C")=C, Named("phi")=phi, Named("states")=states);
#endif
// GS[h]=List::create(Named("beta")=beta, Named("theta")=theta,
// Named("C")=C, Named("phi")=phi, Named("states")=states,
// Named("m")=m, Named("alpha")=alpha, Named("psi")=psi);
}
l++;
} while (l<=(M-1)*thin);
return wrap(GS);
}
