arma_deprecated
inline
typename enable_if2< is_supported_blas_type<typename T1::elem_type>::value, bool >::result
inv_sympd
(
Mat<typename T1::elem_type>& out,
const Base<typename T1::elem_type,T1>& X,
const char* // argument kept only for compatibility with old user code
)
{
arma_extra_debug_sigprint();
// arma_debug_warn("inv_sympd(Y,X,char*) is deprecated and will be removed; change to inv_sympd(Y,X)");
return inv_sympd(out,X);
}
// [[Rcpp::export]]
Rcpp::List aux_quant(arma::mat V, int nc) {
// out is a list with nc+1 elements, where each
// element is a vector of various dimensions. In
// particular:
// - out(0) contains the vector of std.dev of of the various densities.
// - out(1) to out(nc-1) contain the vectors of the regression
// coefs. useful for the nested optimisations.
// - out(nc) contains the vector of log-determinants of blocks of V
Rcpp::List out(nc+1); // the elements of the list are left unspecified
arma::mat S = arma::inv_sympd(V);
arma::vec se(nc, arma::fill::zeros), ldetb(nc, arma::fill::zeros);
// int j = 0;
double sign = 1.0;
se(0) = S(0,0);
arma::log_det(ldetb(0), sign, V);
ldetb(nc-1) = log(V(nc-1,nc-1));
for(int i=1; i<(nc-1); i++){
se(i) = arma::as_scalar(S(i,i) -
S(i,arma::span(0,i-1))*
inv_sympd(S(arma::span(0,i-1),arma::span(0,i-1)))*
trans(S(i,arma::span(0,i-1))));
arma::log_det(ldetb(i), sign, V(arma::span(i,nc-1),arma::span(i,nc-1)));
// out(i) = arma::as_scalar(V(arma::span(i)))
// cnst(j*,j*);
out(i) = inv(V(arma::span(i,nc-1),arma::span(i,nc-1)))*V(arma::span(i,nc-1),i-1);
// std::cout << cnst << std::endl;
}
se(nc-1) = 1.0/V(nc-1,nc-1);
out(0) = sqrt(se);
out(nc-1) = V(nc-1,nc-2)/V(nc-1,nc-1);
out(nc) = ldetb;
// out.names() = "se";
// out.names() = "ldetb";
return out;
}
inline
typename enable_if2< is_supported_blas_type<typename T1::elem_type>::value, bool >::result
inv_sympd
(
Mat<typename T1::elem_type>& out,
const Base<typename T1::elem_type,T1>& X
)
{
arma_extra_debug_sigprint();
try
{
out = inv_sympd(X);
}
catch(std::runtime_error&)
{
return false;
}
return true;
}
inline
bool
inv_sympd
(
Mat<typename T1::elem_type>& out,
const Base<typename T1::elem_type,T1>& X,
const char* method = "std",
const typename arma_blas_type_only<typename T1::elem_type>::result* junk = 0
)
{
arma_extra_debug_sigprint();
arma_ignore(junk);
try
{
out = inv_sympd(X,method);
}
catch(std::runtime_error&)
{
return false;
}
return true;
}
//Calculation of BICreg
List Vect::bicReggen(vector<int> vectH, vector<int> vectY, int numr)
{
double reg = 0.0, sign, val;
// Ici, H est la matrice réponse.
mat H=Vect::const_matrix(vectH);
int n = H.n_rows,v = H.n_cols;
//construction of the matrix X
int a;
if (vectY.empty())
a=0;
else
a=vectY.size();
mat X(n,a+1);
if (vectY.empty())
X.col(0) = ones<colvec>(n);
else
{
mat Y = Vect::const_matrix(vectY);
Y.insert_cols(0, ones<colvec>(n));
X = Y;
}
//Parameter estimation
mat XtX = X.t() * X;
mat B = inv_sympd(XtX) * X.t() *H;
//mat B = pinv(XtX) * X.t() *H;
double lambda;
mat A=X*B;
if (numr==3) //(r=[LC])
{
mat Omega = (1.0/n)*(H.t()*(H-A));
Omega = 2*M_PI*Omega;
log_det(val, sign, Omega);
double det = log(sign*exp(val));
lambda = ((a+1)*v) + (0.5*v*(v+1));
reg = (-n*det)-(n*v)-(lambda*log(n));
}
if (numr==2) //(r=[LB])
{
mat H_A = (1.0/n)*(H - A)%(H - A);
rowvec sigma2 = sum(H_A, 0);
sigma2 = log(sigma2);
lambda=(v*(a+1)) +v;
reg=-(n*v*log(2*M_PI)) - (n* sum(sigma2)) -(n*v) - (lambda*log(n));
}
if (numr==1) //(r=[LI])
{
mat Aux=H-A;
double sigma=(1.0/(n*v))* accu(Aux % Aux);
lambda=(v*(a+1)) + 1;
reg=-(n*v*log(2*M_PI*sigma)) -(n*v) - (lambda*log(n));
}
return List::create(Named("bicvalue") = reg,
Named("B") = B);
}//end Vect::bicReggen
// [[Rcpp::export]]
Rcpp::NumericVector bayes_lm_rcpp_arma_(int n,
int p,
int nsamp,
double prop_nonzero,
double true_beta_sd,
double true_sigma,
double sd_x,
bool print_stats,
bool write_samples,
Rcpp::CharacterVector samples_file_loc,
char decomp_method) {
// Declare model data structures -----------------------
arma::vec true_beta; // true coefficient vector
arma::vec y; // response values
arma::mat X; // predictor coefficient matrix
arma::vec beta; // current value of beta sample
double gamma; // current value of gamma sample
arma::mat Sigma_inv_0; // inverse of beta variance hyperparam
double nu_0; // hyperparam 1 for inverse-gamma prior
double sigma_sq_0; // hyperparam 2 for inverse-gamma prior
arma::mat out_beta; // memory for beta samples
arma::vec out_gamma; // memory for gamma samples
// Declare storage and timer data structures -----------
std::ofstream ctime_file; // sampler loop computational time file
std::ofstream samples_file; // samples file
struct timespec start[3]; // store event starting time information
struct timespec finish[3]; // store event ending time information
double elapsed[3] = { 0, 0, 0 }; // tracks event cumulative elapsed time
arma::vec::iterator curr; // iterator steps through current val
arma::vec::iterator end; // iterator to mark one past the last val
// Set values of model objects -------------------------
// Set values of beta
true_beta = sample_beta(p, prop_nonzero, true_beta_sd);
// Sample data
X.randn(n, p);
X *= sd_x;
y = (X * true_beta) + (true_sigma * arma::vec(n, arma::fill::randn));
/* Set the priors; see Hoff pgs. 154-155 for the meanings of the priors.
* Note: we are implicitely specifying the mean hyperparameter for beta to
* be 0 by ommitting the term in the Gibbs sampler conditional mean
* calculation.
*/
Sigma_inv_0.eye(p, p);
nu_0 = 1;
sigma_sq_0 = 1;
// Write param vals to file ----------------------------
// Write true values of beta, sigma^{-2} to the first row of output file
if (write_samples) {
samples_file.open(samples_file_loc[0].begin());
curr = true_beta.begin();
end = true_beta.end();
for ( ; (curr != end); curr++) {
samples_file << *curr << " ";
}
samples_file << 1 / (true_sigma * true_sigma) << "\n";
samples_file.close();
}
// Preliminary calculations ----------------------------
arma::mat tXX; // value of X^{T} X
arma::vec tXy; // value of X^{T} y
double shapeval; // shape parameter for gamma distribution samples
double nu_sigma_sq_0; // product of nu_0 and sigma^2_0
tXX = X.t() * X;
tXy = X.t() * y;
nu_sigma_sq_0 = nu_0 * sigma_sq_0;
shapeval = (nu_0 + n) / 2;
// Sampler loop ----------------------------------------
arma::mat V; // variance of current beta sample
arma::vec m; // mean of current beta sample
arma::vec err; // model error, i.e. y - X \beta
double root_SSR; // square root of SSR
double SSR; // SSR (sum of squared errors)
double scaleval; // scale parameter for gamma distribution samples
// Set pointer to desired multivariate normal sampling function
arma::vec (*samp_mvnorm)(arma::vec&, arma::mat&);
switch (decomp_method) {
case 'c':
samp_mvnorm = &mvrnorm_chol;
break;
case 'e':
samp_mvnorm = &mvrnorm_eigen;
break;
default:
throw std::runtime_error("Illegal value of decomp_method");
}
// Conditionally allocate memory for samples
if (print_stats) {
out_beta.set_size(p, nsamp);
out_gamma.set_size(nsamp);
}
// Conditionally open samples file stream
if (write_samples) {
samples_file.open(samples_file_loc[0].begin(), std::fstream::app);
}
// Clock timer objects and initialization; requires POSIX system
CLOCK_START(OVERALL);
// Initial value for gamma
gamma = 1;
for (int s = 0; s < nsamp; s++) {
// Sample beta
CLOCK_START(INVERSE)
V = inv_sympd(Sigma_inv_0 + (gamma * tXX));
CLOCK_STOP(INVERSE);
m = gamma * V * tXy;
CLOCK_START(SAMP_NORM)
beta = samp_mvnorm(m, V);
CLOCK_STOP(SAMP_NORM);
// Sample gamma
err = y - (X * beta);
root_SSR = norm(err);
SSR = root_SSR * root_SSR;
scaleval = 2 / (nu_sigma_sq_0 + SSR);
gamma = Rf_rgamma(shapeval, scaleval);
// Conditionally store data in memory / write to file
if (write_samples) {
curr = beta.begin();
end = beta.end();
for ( ; (curr != end); curr++) {
samples_file << *curr << " ";
}
samples_file << gamma << "\n";
}
if (print_stats) {
out_beta.col(s) = beta;
out_gamma(s) = gamma;
}
// Allow user to interrupt and return to the R REPL
if (s % 1000 == 0) {
Rcpp::checkUserInterrupt();
}
}
// Calculate elapsed time
CLOCK_STOP(OVERALL);
// Print summary statistics ----------------------------
if (print_stats) {
// Create tables with true values and empirical quantiles
arma::mat table_beta_quant;
arma::mat table_gamma_quant;
// Declare and initialize probs, true_gamma
arma::vec probs;
arma::vec true_gamma;
probs << 0.025 << 0.500 << 0.975;
true_gamma << 1 / (true_sigma * true_sigma);
// Calculate empirical quantiles
out_beta = out_beta.t();
table_beta_quant = quantile_table(true_beta, out_beta, probs);
table_gamma_quant = quantile_table(true_gamma, out_gamma, probs);
Rcpp::Rcout << "\n"
<< "Parameter specifications:\n"
<< "-------------------------\n"
<< "n: " << n << "\n"
<< "p: " << p << "\n"
<< "prop_nonzero: " << prop_nonzero << "\n"
<< "true_beta_sd: " << true_beta_sd << "\n"
<< "true_sigma: " << true_sigma << "\n"
<< "sd_x: " << sd_x << "\n"
<< "nsamp: " << nsamp << "\n"
<< "print_stats: " << print_stats << "\n"
<< "write_samples: " << write_samples << "\n"
<< "samples_file_loc: " << samples_file_loc << "\n"
<< "decomp_method: " << decomp_method << "\n";
Rcpp::Rcout << "\n"
<< "Elapsed time:\n"
<< "-------------\n"
<< "Inverse: " << elapsed[INVERSE] << "\n"
<< "Sampling normal: " << elapsed[SAMP_NORM] << "\n"
<< "Overall: " << elapsed[OVERALL] << "\n"
<< "\n";
Rcpp::Rcout << "true beta 2.5% 50% 97.5%\n"
<< "------------------------------------\n"
<< table_beta_quant
<< "\n"
<< " true gam 2.5% 50% 97.5%\n"
<< "------------------------------------\n"
<< table_gamma_quant
<< "\n";
}
// Return computational time
return Rcpp::NumericVector::create(Rcpp::Named("inverse") = elapsed[INVERSE],
Rcpp::Named("mvnsamp") = elapsed[SAMP_NORM],
Rcpp::Named("overall") = elapsed[OVERALL]);
}
