void draw_uncollapsed_xaya(std::vector<double> &xaya, std::vector<double> &xa, std::vector<double> &xag, std::vector<double> Bg, double phi, int na, int p, int p_gamma)
{
double sd=sqrt(1/phi);
std::vector<double> Z(na);
for(std::vector<double>::iterator it=Z.begin(); it!=Z.end(); ++it) *it=Rf_rnorm(0,1);
if(p_gamma!=0){
dgemv_(&transN , &na, &p_gamma, &unity, &*xag.begin(), &na, &*Bg.begin(), &inc, &inputscale0, &*xaya.begin(), &inc);
daxpy_(&p, &sd, &*Z.begin(), &inc, &*xaya.begin(), &inc);
//dtrmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &na, &*xaya.begin(), &inc);
dtpmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &*xaya.begin(), &inc);
}else{
for(size_t i=0; i!=xaya.size(); ++i) xaya[i]=sd*Z[i];
//dtrmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &na, &*xaya.begin(), &inc);
dtpmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &*xaya.begin(), &inc);
}
}
int GlmTest::resampNonCase(glm *model, gsl_matrix *bT, unsigned int i)
{
unsigned int j, k, id;
double bt, score, yij, mij;
gsl_vector_view yj;
unsigned int nRows=tm->nRows, nVars=tm->nVars;
// note that residuals have got means subtracted
switch (tm->resamp) {
case RESIBOOT:
if (tm->reprand!=TRUE) GetRNGstate();
for (j=0; j<nRows; j++) {
if (bootID!=NULL)
id = (unsigned int) gsl_matrix_get(bootID, i, j);
else if (tm->reprand==TRUE)
id = (unsigned int) gsl_rng_uniform_int(rnd, nRows);
else id = (unsigned int) nRows * Rf_runif(0, 1);
// bY = mu+(bootr*sqrt(variance))
for (k=0; k<nVars; k++) {
bt=gsl_matrix_get(model->Mu,j,k)+sqrt(gsl_matrix_get(model->Var,j,k))*gsl_matrix_get(model->Res, id, k);
bt = MAX(bt, 0.0);
bt = MIN(bt, model->maxtol);
gsl_matrix_set(bT, j, k, bt);
} }
if (tm->reprand!=TRUE) PutRNGstate();
break;
case SCOREBOOT:
for (j=0; j<nRows; j++) {
if (bootID!=NULL)
score = (double) gsl_matrix_get(bootID, i, j);
else if (tm->reprand==TRUE)
score = gsl_ran_ugaussian (rnd);
else score = Rf_rnorm(0.0, 1.0);
// bY = mu + score*sqrt(variance)
for (k=0; k<nVars; k++){
bt=gsl_matrix_get(model->Mu, j, k)+sqrt(gsl_matrix_get(model->Var, j, k))*gsl_matrix_get(model->Res, j, k)*score;
bt = MAX(bt, 0.0);
bt = MIN(bt, model->maxtol);
gsl_matrix_set(bT, j, k, bt);
} }
break;
case PERMUTE:
if (bootID==NULL)
gsl_ran_shuffle(rnd,permid,nRows,sizeof(unsigned int));
for (j=0; j<nRows; j++) {
if (bootID==NULL) id = permid[j];
else id = (unsigned int) gsl_matrix_get(bootID, i, j);
// bY = mu + bootr * sqrt(var)
for (k=0; k<nVars; k++) {
bt=gsl_matrix_get(model->Mu,j,k)+sqrt(gsl_matrix_get(model->Var,j,k))*gsl_matrix_get(model->Res, id, k);
bt = MAX(bt, 0.0);
bt = MIN(bt, model->maxtol);
gsl_matrix_set(bT, j, k, bt);
} }
break;
case FREEPERM:
if (bootID==NULL)
gsl_ran_shuffle(rnd,permid,nRows,sizeof(unsigned int));
for (j=0; j<nRows; j++) {
if (bootID==NULL) id = permid[j];
else id = (unsigned int) gsl_matrix_get(bootID, i, j);
yj=gsl_matrix_row(model->Yref, id);
gsl_matrix_set_row (bT, j, &yj.vector);
}
break;
case MONTECARLO:
McSample(model, rnd, XBeta, Sigma, bT);
break;
case PITSBOOT:
if (tm->reprand!=TRUE) GetRNGstate();
for (j=0; j<nRows; j++) {
if (bootID!=NULL)
id = (unsigned int) gsl_matrix_get(bootID, i, j);
else if (tm->reprand==TRUE)
id = (unsigned int) gsl_rng_uniform_int(rnd, nRows);
else id = (unsigned int) Rf_runif(0, nRows);
for (k=0; k<nVars; k++) {
bt = gsl_matrix_get(model->PitRes, id, k);
mij = gsl_matrix_get(model->Mu, j, k);
yij = model->cdfinv(bt, mij, model->theta[k]);
gsl_matrix_set(bT, j, k, yij);
}
}
if (tm->reprand!=TRUE) PutRNGstate();
break;
default: GSL_ERROR("The resampling method is not supported", GSL_ERANGE); break;
}
return SUCCESS;
}
Type rnorm(Type mu, Type sigma)
{
return Rf_rnorm(asDouble(mu), asDouble(sigma));
}
extern "C" void glm_gibbs(double * rZ, double * rxo, double * rlam, int * rmodelprior, double * rpriorprob, double * rbeta1, double * rbeta2, int * rburnin, int * rniter, int * rscalemixture, double * ralpha, int * rno, int * rna, int * rp, double * B_mcmc, double * prob_mcmc, int * gamma_mcmc, double * phi_mcmc, double * lam_mcmc, double * B_rb, double * prob_rb, double * intercept_mcmc, double * xo_scale)
{
GetRNGstate();
//MCMC Variables//
int burnin=*rburnin;
int niter=*rniter;
//Dimensions//
int p=*rp;
int no=*rno;
int na=*rna;
//Phi Variables//
double phi=1.0;
//Yo Variables//
std::vector<double> Z(rZ, rZ+no);
std::vector<double> xo(rxo, rxo+no*p);
standardize_xo(xo,xo_scale,no,p);
std::vector<double> xoyo(p);
double yobar=0;
std::vector<double> xoxo(p*p);
dgemm_( &transT, &transN, &p, &p, &no, &unity, &*xo.begin(), &no, &*xo.begin(), &no, &inputscale0, &*xoxo.begin(), &p );
//Construct Xa//
std::vector<double> xa(p*(p+1)/2); //Triangular Packed Storage
std::vector<double> d(p);
chol_xa(xa,xoxo,d,p);
//Reserve Memory for Submatrices//
std::vector<double> xog; xog.reserve(no*p);
std::vector<double> xogyo; xogyo.reserve(p);
std::vector<double> xogxog_Lamg; xogxog_Lamg.reserve(p*p);
std::vector<double> xag; xag.reserve(na*p);
//Ya Variables//
std::vector<double> xaya(p);
//Beta Variables//
double intercept=0;
std::vector<double> Bols(p);
std::vector<double> B(p,0.0);
std::vector<double> Bg; Bg.reserve(p);
//Lambda Variables//
int scalemixture=*rscalemixture;
double alpha=*ralpha;
std::vector<double> lam(rlam,rlam+p);
std::vector<double> lamg; lamg.reserve(p); //vector instead of diagonal pxp matrix
//Gamma Variables//
std::vector<int> gamma(p,1);
int p_gamma=std::accumulate(gamma.begin(),gamma.end(),0);
bool gamma_diff=true;
int modelprior=*rmodelprior;
//Probability Variables//
std::vector<double> prob(p);
std::vector<double> odds(p);
std::vector<double> priorprob(rpriorprob,rpriorprob+p);
//Theta Variables//
double theta=0.5;
double beta1=*rbeta1;
double beta2=*rbeta2;
//Store Initial Values//
std::copy(B.begin(),B.end(),B_mcmc);
std::copy(prob.begin(),prob.end(),prob_mcmc);
std::copy(gamma.begin(),gamma.end(),gamma_mcmc);
std::copy(lam.begin(),lam.end(),lam_mcmc);
//Run Gibbs Sampler//
for (int t = 1; t < niter; ++t)
{
//Form Submatrices//
if(p_gamma) submatrices_uncollapsed(gamma_diff,B,xog,xag,lamg,Bg,gamma,lam,xo,xa,p_gamma,p,no,na);
//Draw xoyo//
draw_xoyo(Z,xoyo,yobar,xo,xog,Bg,phi,no,p,p_gamma,intercept);
//Draw xaya//
draw_uncollapsed_xaya(xaya,xa,xag,Bg,phi,na,p,p_gamma);
//Compute Probabilities//
if(modelprior==1)
{
bernoulli_probabilities(prob,odds,Bols,d,xoyo,xaya,priorprob,lam,phi);
}else if(modelprior==2)
{
betabinomial_probabilities(prob,odds,Bols,d,xoyo,xaya,theta,lam,phi);
}else
{
uniform_probabilities(prob,odds,Bols,d,xoyo,xaya,lam,phi);
}
//Draw Gamma//
draw_gamma(gamma,p_gamma,prob);
//Draw Theta//
if(modelprior==2) theta=Rf_rbeta(beta1+p_gamma,p-p_gamma+beta2);
//Draw Beta//
draw_beta(gamma,B,Bols,d,lam,phi);
//Draw Intercept//
intercept=yobar+sqrt(1/(no*phi))*Rf_rnorm(0,1);
//Draw Lambda//
if(scalemixture) draw_lambda_t(lam,gamma,alpha,B,phi);
//Store Draws//
intercept_mcmc[t]=intercept;
std::copy(gamma.begin(),gamma.end(),(gamma_mcmc+p*t));
std::copy(prob.begin(),prob.end(),(prob_mcmc+p*t));
std::copy(B.begin(),B.end(),(B_mcmc+p*t));
std::copy(lam.begin(),lam.end(),(lam_mcmc+p*t));
//Rao Blackwell//
if(t>=burnin) rao_blackwell(B_rb,prob_rb,B,prob,burnin,niter);
//Has Gamma Changed?//
gamma_diff=gamma_change(gamma_mcmc,t,p);
}
PutRNGstate();
}
int MCMCPkPg::sampleTheta( PkPgModel& model, PkPgResult& Result ){
//int i, v, j;
double fx0, fx1, ratio, u;
mat proplogTheta( model.N, model.V ); // Proposal for Theta. In matrix with vision of parallelizing in the future
mat propTheta( model.N, model.V );
// Loop subjects ---------------------------------------------------
for( size_t i = 0; i < model.N; i++ ){
// current posterior log likelihood
colvec CurrentlogTheta = Result.logTheta.row( i ).t();
fx0 = f_theta( CurrentlogTheta, Result.mTheta.row( i ).t(),
Result.Otheta, 1.0, //Result.Tau( i ),
model.Y.slice( i ), Result.Fit.slice( i ),
Result.Sigma.row( i ) , log(Result.EHRTime(i,0)));
// propoal ----------- start -----------
colvec theta_bar_i = Result.logTheta_bar.row( i ).t();
mat sigma_theta_i = Result.Sigma_theta.slice( i );
//colvec ProplogThetaCenter = CurrentlogTheta + 2 * ( Result.logTheta_MLE.row(i).t() - CurrentlogTheta );
//colvec logtemp = MVNORM( 0, ProplogThetaCenter , sigma_theta_i ) ; // proposal
colvec logtemp = MVNORM( 0, CurrentlogTheta , sigma_theta_i ) ; // proposal
proplogTheta.row( i ) = logtemp.t();
//logtemp.print("logtemp");
propTheta.row( i ) = exp( proplogTheta.row( i ) );
rowvec tempPThetaRow(15);
for( int j = 0; j< 10; j++)tempPThetaRow(j) = propTheta( i, j );
double proplogEHRTime = Rf_rnorm(log(Result.EHRTime(i,0)),0.1);
double propEHRTime = exp( proplogEHRTime );
tempPThetaRow(10) = propEHRTime; //Result.EHRTime(i,0);
for( int j = 10; j< 14; j++) tempPThetaRow(j+1) = propTheta( i, j );
rowvec param = tempPThetaRow;
mat TempFit = fev( model.PkModel, model.env, model.K, model.T, param, i ); // update the likelihood
if( TempFit.n_cols==model.K){
uvec idx = find( TempFit < 0.00001 );
TempFit.elem( idx ) = ones<vec>( idx.n_elem ) * 0.00001;
// propoal ----------- end -----------
// proposed posterior log likelihood
fx1 = f_theta( proplogTheta.row( i ).t(), Result.mTheta.row( i ).t(),
Result.Otheta, 1.0, //Result.Tau(i),
model.Y.slice( i ), TempFit,
Result.Sigma.row( i ), proplogEHRTime );
// Accept or Reject
ratio = fx1 - fx0; // M-H ratio
u = Rf_runif( 0, 1 );
if( log( u ) < ratio ){
// for( v = 0; v < model.V; v++ ) {
// Result.Theta( i, v ) = propTheta( i, v ); // Update theta_v
// }
acceptTheta(i,cIter)=1;
Result.logTheta_old.row( i ) = Result.logTheta.row( i );
Result.logTheta.row( i ) = proplogTheta.row( i );
Result.Theta.row( i ) = propTheta.row( i );
Result.Fit.slice( i ) = TempFit;
Result.EHRTime(i,0) = propEHRTime;
} else {
Result.logTheta_old.row( i ) = Result.logTheta.row( i );
Result.logTheta.row( i ) = Result.logTheta.row( i );
Result.Theta.row( i ) = Result.Theta.row( i );
Result.Fit.slice( i ) = Result.Fit.slice( i );
}
} else{
acceptTheta(i,cIter)=-1;
Result.logTheta_old.row( i ) = Result.logTheta.row( i );
Result.logTheta.row( i ) = Result.logTheta.row( i );
Result.Theta.row( i ) = Result.Theta.row( i );
Result.Fit.slice( i ) = Result.Fit.slice( i );
}
} // end loop i
return 0;
}
