inline bool
check_cholesky_factor(
const char* function,
const char* name,
const Eigen::Matrix<T_y, Eigen::Dynamic, Eigen::Dynamic>& y
) {
check_less_or_equal(function, "columns and rows of Cholesky factor",
y.cols(), y.rows());
check_positive(function, "columns of Cholesky factor", y.cols());
check_lower_triangular(function, name, y);
for (int i = 0; i < y.cols(); ++i)
// FIXME: should report row
check_positive(function, name, y(i, i));
return true;
}
inline bool check_corr_matrix(const char* function,
const Eigen::Matrix<T_y,Eigen::Dynamic,Eigen::Dynamic>& y,
const char* name,
T_result* result,
const Policy&) {
if (!check_size_match(function,
y.rows(), "Rows of correlation matrix",
y.cols(), "columns of correlation matrix",
result, Policy()))
return false;
if (!check_positive(function, y.rows(), "rows", result, Policy()))
return false;
if (!check_symmetric(function, y, "y", result, Policy()))
return false;
for (typename Eigen::Matrix<T_y,Eigen::Dynamic,Eigen::Dynamic>::size_type
k = 0; k < y.rows(); ++k) {
if (fabs(y(k,k) - 1.0) > CONSTRAINT_TOLERANCE) {
std::ostringstream message;
message << name << " is not a valid correlation matrix. "
<< name << "(" << k << "," << k
<< ") is %1%, but should be near 1.0";
T_result tmp
= policies::raise_domain_error<T_y>(function,
message.str().c_str(),
y(k,k), Policy());
if (result != 0)
*result = tmp;
return false;
}
}
if (!check_pos_definite(function, y, "y", result, Policy()))
return false;
return true;
}
inline typename boost::math::tools::promote_args<T1, T2>::type
log_falling_factorial(const T1 x, const T2 n) {
if (is_nan(x) || is_nan(n))
return std::numeric_limits<double>::quiet_NaN();
static const char* fun = "log_falling_factorial";
check_positive(fun, "first argument", x);
return lgamma(x + 1) - lgamma(x - n + 1);
}
inline bool check_cov_matrix(const std::string& function,
const std::string& name,
const Eigen::Matrix<T_y,Eigen::Dynamic,Eigen::Dynamic>& y) {
check_size_match(function,
"Rows of covariance matrix", y.rows(),
"columns of covariance matrix", y.cols());
check_positive(function, "rows", y.rows());
check_symmetric(function, name, y);
check_pos_definite(function, name, y);
return true;
}
inline double
pareto_type_2_rng(double mu,
double lambda,
double alpha,
RNG& rng) {
static const char* function("pareto_type_2_rng");
check_positive(function, "scale parameter", lambda);
double uniform_01 = uniform_rng(0.0, 1.0, rng);
return (std::pow(1.0 - uniform_01, -1.0 / alpha) - 1.0) * lambda + mu;
}
inline
Eigen::Matrix<typename boost::math::tools::promote_args<T1, T2>::type,
Eigen::Dynamic, 1>
csr_matrix_times_vector(const int& m,
const int& n,
const Eigen::Matrix<T1, Eigen::Dynamic, 1>& w,
const std::vector<int>& v,
const std::vector<int>& u,
const Eigen::Matrix<T2, Eigen::Dynamic, 1>& b) {
typedef typename boost::math::tools::promote_args<T1, T2>::type
result_t;
check_positive("csr_matrix_times_vector", "m", m);
check_positive("csr_matrix_times_vector", "n", n);
check_size_match("csr_matrix_times_vector", "n", n, "b", b.size());
check_size_match("csr_matrix_times_vector", "m", m, "u", u.size() - 1);
check_size_match("csr_matrix_times_vector", "w", w.size(), "v", v.size());
check_size_match("csr_matrix_times_vector", "u/z",
u[m - 1] + csr_u_to_z(u, m - 1) - 1, "v", v.size());
for (unsigned int i = 0; i < v.size(); ++i)
check_range("csr_matrix_times_vector", "v[]", n, v[i]);
Eigen::Matrix<result_t, Eigen::Dynamic, 1> result(m);
result.setZero();
for (int row = 0; row < m; ++row) {
int idx = csr_u_to_z(u, row);
int row_end_in_w = (u[row] - stan::error_index::value) + idx;
int i = 0; // index into dot-product segment entries.
Eigen::Matrix<result_t, Eigen::Dynamic, 1> b_sub(idx);
b_sub.setZero();
for (int nze = u[row] - stan::error_index::value;
nze < row_end_in_w; ++nze, ++i) {
check_range("csr_matrix_times_vector", "j", n, v[nze]);
b_sub.coeffRef(i) = b.coeffRef(v[nze] - stan::error_index::value);
} // loop skipped when z is zero.
Eigen::Matrix<T1, Eigen::Dynamic, 1>
w_sub(w.segment(u[row] - stan::error_index::value, idx));
result.coeffRef(row) = dot_product(w_sub, b_sub);
}
return result;
}
typename boost::math::tools::promote_args<T_y, T_covar, T_w>::type
multi_gp_cholesky_log(const Eigen::Matrix
<T_y, Eigen::Dynamic, Eigen::Dynamic>& y,
const Eigen::Matrix
<T_covar, Eigen::Dynamic, Eigen::Dynamic>& L,
const Eigen::Matrix<T_w, Eigen::Dynamic, 1>& w) {
static const char* function("multi_gp_cholesky_log");
typedef
typename boost::math::tools::promote_args<T_y, T_covar, T_w>::type T_lp;
T_lp lp(0.0);
check_size_match(function,
"Size of random variable (rows y)", y.rows(),
"Size of kernel scales (w)", w.size());
check_size_match(function,
"Size of random variable", y.cols(),
"rows of covariance parameter", L.rows());
check_finite(function, "Kernel scales", w);
check_positive(function, "Kernel scales", w);
check_finite(function, "Random variable", y);
if (y.rows() == 0)
return lp;
if (include_summand<propto>::value) {
lp += NEG_LOG_SQRT_TWO_PI * y.rows() * y.cols();
}
if (include_summand<propto, T_covar>::value) {
lp -= L.diagonal().array().log().sum() * y.rows();
}
if (include_summand<propto, T_w>::value) {
lp += 0.5 * y.cols() * sum(log(w));
}
if (include_summand<propto, T_y, T_w, T_covar>::value) {
T_lp sum_lp_vec(0.0);
for (int i = 0; i < y.rows(); i++) {
Eigen::Matrix<T_y, Eigen::Dynamic, 1> y_row(y.row(i));
Eigen::Matrix<typename boost::math::tools::promote_args
<T_y, T_covar>::type,
Eigen::Dynamic, 1>
half(mdivide_left_tri_low(L, y_row));
sum_lp_vec += w(i) * dot_self(half);
}
lp -= 0.5*sum_lp_vec;
}
return lp;
}
inline bool check_cov_matrix(const char* function,
const Eigen::Matrix<T_y,Eigen::Dynamic,Eigen::Dynamic>& y,
const char* name,
T_result* result) {
check_size_match(function,
y.rows(), "Rows of covariance matrix",
y.cols(), "columns of covariance matrix",
result);
check_positive(function, y.rows(), "rows", result);
check_symmetric(function, y, name, result);
check_pos_definite(function, y, name, result);
return true;
}
typename boost::math::tools::promote_args<T_y, T_covar, T_w>::type
multi_gp_log(const Eigen::Matrix<T_y, Eigen::Dynamic, Eigen::Dynamic>& y,
const Eigen::Matrix
<T_covar, Eigen::Dynamic, Eigen::Dynamic>& Sigma,
const Eigen::Matrix<T_w, Eigen::Dynamic, 1>& w) {
static const char* function("multi_gp_log");
typedef typename boost::math::tools::promote_args<T_y, T_covar, T_w>::type
T_lp;
T_lp lp(0.0);
check_positive(function, "Kernel rows", Sigma.rows());
check_finite(function, "Kernel", Sigma);
check_symmetric(function, "Kernel", Sigma);
LDLT_factor<T_covar, Eigen::Dynamic, Eigen::Dynamic> ldlt_Sigma(Sigma);
check_ldlt_factor(function, "LDLT_Factor of Sigma", ldlt_Sigma);
check_size_match(function,
"Size of random variable (rows y)", y.rows(),
"Size of kernel scales (w)", w.size());
check_size_match(function,
"Size of random variable", y.cols(),
"rows of covariance parameter", Sigma.rows());
check_positive_finite(function, "Kernel scales", w);
check_finite(function, "Random variable", y);
if (y.rows() == 0)
return lp;
if (include_summand<propto>::value) {
lp += NEG_LOG_SQRT_TWO_PI * y.rows() * y.cols();
}
if (include_summand<propto, T_covar>::value) {
lp -= 0.5 * log_determinant_ldlt(ldlt_Sigma) * y.rows();
}
if (include_summand<propto, T_w>::value) {
lp += (0.5 * y.cols()) * sum(log(w));
}
if (include_summand<propto, T_y, T_w, T_covar>::value) {
Eigen::Matrix<T_w, Eigen::Dynamic, Eigen::Dynamic>
w_mat(w.asDiagonal());
Eigen::Matrix<T_y, Eigen::Dynamic, Eigen::Dynamic> yT(y.transpose());
lp -= 0.5 * trace_gen_inv_quad_form_ldlt(w_mat, ldlt_Sigma, yT);
}
return lp;
}
AggregatedRegressionSampler::AggregatedRegressionSampler(
AggregatedRegressionModel *model,
double prior_sigma_nobs,
double prior_sigma_guess,
double prior_beta_nobs,
double prior_diagonal_shrinkage,
double prior_variable_inclusion_probability)
: model_(model),
sam_(new BregVsSampler(model_->regression_model(),
prior_sigma_nobs,
prior_sigma_guess,
prior_beta_nobs,
prior_diagonal_shrinkage,
prior_variable_inclusion_probability))
{
check_positive(prior_sigma_guess, "prior_sigma_guess");
check_positive(prior_sigma_nobs, "prior_sigma_nobs");
check_positive(prior_beta_nobs, "prior_beta_nobs");
check_positive(prior_diagonal_shrinkage, "prior_diagonal_shrinkage");
check_positive(prior_variable_inclusion_probability,
"prior_variable_inclusion_probability");
model_->set_method(sam_);
}
inline bool check_positive(const char* function,
const T_x& x,
const char* name,
T_result* result) {
return check_positive(function,x,name,result,default_policy());
}
/**
* Return the z vector computed from the specified u vector at the
* index for the z vector.
*
* @param[in] u U vector.
* @param[in] i Index into resulting z vector.
* @return z[i] where z is conversion from u.
*/
int csr_u_to_z(const std::vector<int>& u, int i) {
check_positive("csr_u_to_z", "u.size()", u.size());
check_range("csr_u_to_z", "i", u.size(), i + 1, "index out of range");
return u[i + 1] - u[i];
}
SEXP hitrun(SEXP alpha, SEXP initial, SEXP nbatch, SEXP blen, SEXP nspac,
SEXP origin, SEXP basis, SEXP amat, SEXP bvec, SEXP outmat, SEXP debug)
{
if (! isReal(alpha))
error("argument \"alpha\" must be type double");
if (! isReal(initial))
error("argument \"initial\" must be type double");
if (! isInteger(nbatch))
error("argument \"nbatch\" must be type integer");
if (! isInteger(blen))
error("argument \"blen\" must be type integer");
if (! isInteger(nspac))
error("argument \"nspac\" must be type integer");
if (! isReal(origin))
error("argument \"origin\" must be type double");
if (! isReal(basis))
error("argument \"basis\" must be type double");
if (! isReal(amat))
error("argument \"amat\" must be type double");
if (! isReal(bvec))
error("argument \"bvec\" must be type double");
if (! (isNull(outmat) | isReal(outmat)))
error("argument \"outmat\" must be type double or NULL");
if (! isLogical(debug))
error("argument \"debug\" must be logical");
if (! isMatrix(basis))
error("argument \"basis\" must be matrix");
if (! isMatrix(amat))
error("argument \"amat\" must be matrix");
if (! (isNull(outmat) | isMatrix(outmat)))
error("argument \"outmat\" must be matrix or NULL");
int dim_oc = LENGTH(alpha);
int dim_nc = LENGTH(initial);
int ncons = nrows(amat);
if (LENGTH(nbatch) != 1)
error("argument \"nbatch\" must be scalar");
if (LENGTH(blen) != 1)
error("argument \"blen\" must be scalar");
if (LENGTH(nspac) != 1)
error("argument \"nspac\" must be scalar");
if (LENGTH(origin) != dim_oc)
error("length(origin) != length(alpha)");
if (nrows(basis) != dim_oc)
error("nrow(basis) != length(alpha)");
if (ncols(basis) != dim_nc)
error("ncol(basis) != length(initial)");
if (ncols(amat) != dim_nc)
error("ncol(amat) != length(initial)");
if (LENGTH(bvec) != ncons)
error("length(bvec) != nrow(amat)");
if (LENGTH(debug) != 1)
error("argument \"debug\" must be scalar");
int dim_out = dim_oc;
if (! isNull(outmat)) {
dim_out = nrows(outmat);
if (ncols(outmat) != dim_oc)
error("ncol(outmat) != length(alpha)");
}
int int_nbatch = INTEGER(nbatch)[0];
int int_blen = INTEGER(blen)[0];
int int_nspac = INTEGER(nspac)[0];
int int_debug = LOGICAL(debug)[0];
double *dbl_star_alpha = REAL(alpha);
double *dbl_star_initial = REAL(initial);
double *dbl_star_origin = REAL(origin);
double *dbl_star_basis = REAL(basis);
double *dbl_star_amat = REAL(amat);
double *dbl_star_bvec = REAL(bvec);
int has_outmat = isMatrix(outmat);
double *dbl_star_outmat = 0;
if (has_outmat)
dbl_star_outmat = REAL(outmat);
if (int_nbatch <= 0)
error("argument \"nbatch\" must be positive");
if (int_blen <= 0)
error("argument \"blen\" must be positive");
if (int_nspac <= 0)
error("argument \"nspac\" must be positive");
check_finite(dbl_star_alpha, dim_oc, "alpha");
check_positive(dbl_star_alpha, dim_oc, "alpha");
check_finite(dbl_star_initial, dim_nc, "initial");
check_finite(dbl_star_origin, dim_oc, "origin");
check_finite(dbl_star_basis, dim_oc * dim_nc, "basis");
check_finite(dbl_star_amat, ncons * dim_nc, "amat");
check_finite(dbl_star_bvec, ncons, "bvec");
if (has_outmat)
check_finite(dbl_star_outmat, dim_out * dim_oc, "outmat");
double *state = (double *) R_alloc(dim_nc, sizeof(double));
double *proposal = (double *) R_alloc(dim_nc, sizeof(double));
double *batch_buffer = (double *) R_alloc(dim_out, sizeof(double));
double *out_buffer = (double *) R_alloc(dim_out, sizeof(double));
memcpy(state, dbl_star_initial, dim_nc * sizeof(double));
logh_setup(dbl_star_alpha, dbl_star_origin, dbl_star_basis, dim_oc, dim_nc);
double current_log_dens = logh(state);
out_setup(dbl_star_origin, dbl_star_basis, dbl_star_outmat, dim_oc, dim_nc,
dim_out, has_outmat);
SEXP result, resultnames, path, save_initial, save_final;
if (! int_debug) {
PROTECT(result = allocVector(VECSXP, 3));
PROTECT(resultnames = allocVector(STRSXP, 3));
} else {
PROTECT(result = allocVector(VECSXP, 11));
PROTECT(resultnames = allocVector(STRSXP, 11));
}
PROTECT(path = allocMatrix(REALSXP, dim_out, int_nbatch));
SET_VECTOR_ELT(result, 0, path);
PROTECT(save_initial = duplicate(initial));
SET_VECTOR_ELT(result, 1, save_initial);
UNPROTECT(2);
SET_STRING_ELT(resultnames, 0, mkChar("batch"));
SET_STRING_ELT(resultnames, 1, mkChar("initial"));
SET_STRING_ELT(resultnames, 2, mkChar("final"));
if (int_debug) {
SEXP spath, ppath, zpath, u1path, u2path, s1path, s2path, gpath;
int nn = int_nbatch * int_blen * int_nspac;
PROTECT(spath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 3, spath);
PROTECT(ppath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 4, ppath);
PROTECT(zpath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 5, zpath);
PROTECT(u1path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 6, u1path);
PROTECT(u2path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 7, u2path);
PROTECT(s1path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 8, s1path);
PROTECT(s2path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 9, s2path);
PROTECT(gpath = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 10, gpath);
UNPROTECT(8);
SET_STRING_ELT(resultnames, 3, mkChar("current"));
SET_STRING_ELT(resultnames, 4, mkChar("proposal"));
SET_STRING_ELT(resultnames, 5, mkChar("z"));
SET_STRING_ELT(resultnames, 6, mkChar("u1"));
SET_STRING_ELT(resultnames, 7, mkChar("u2"));
SET_STRING_ELT(resultnames, 8, mkChar("s1"));
SET_STRING_ELT(resultnames, 9, mkChar("s2"));
SET_STRING_ELT(resultnames, 10, mkChar("log.green"));
}
namesgets(result, resultnames);
UNPROTECT(1);
GetRNGstate();
if (current_log_dens == R_NegInf)
error("log unnormalized density -Inf at initial state");
for (int ibatch = 0, k = 0; ibatch < int_nbatch; ibatch++) {
for (int i = 0; i < dim_out; i++)
batch_buffer[i] = 0.0;
for (int jbatch = 0; jbatch < int_blen; jbatch++) {
double proposal_log_dens;
for (int ispac = 0; ispac < int_nspac; ispac++) {
/* Note: should never happen! */
if (current_log_dens == R_NegInf)
error("log density -Inf at current state");
double u1 = R_NaReal;
double u2 = R_NaReal;
double smax = R_NaReal;
double smin = R_NaReal;
double z[dim_nc];
propose(state, proposal, dbl_star_amat, dbl_star_bvec,
dim_nc, ncons, z, &smax, &smin, &u1);
proposal_log_dens = logh(proposal);
int accept = FALSE;
if (proposal_log_dens != R_NegInf) {
if (proposal_log_dens >= current_log_dens) {
accept = TRUE;
} else {
double green = exp(proposal_log_dens
- current_log_dens);
u2 = unif_rand();
accept = u2 < green;
}
}
if (int_debug) {
int l = ispac + int_nspac * (jbatch + int_blen * ibatch);
int lbase = l * dim_nc;
SEXP spath = VECTOR_ELT(result, 3);
SEXP ppath = VECTOR_ELT(result, 4);
SEXP zpath = VECTOR_ELT(result, 5);
SEXP u1path = VECTOR_ELT(result, 6);
SEXP u2path = VECTOR_ELT(result, 7);
SEXP s1path = VECTOR_ELT(result, 8);
SEXP s2path = VECTOR_ELT(result, 9);
SEXP gpath = VECTOR_ELT(result, 10);
for (int lj = 0; lj < dim_nc; lj++) {
REAL(spath)[lbase + lj] = state[lj];
REAL(ppath)[lbase + lj] = proposal[lj];
REAL(zpath)[lbase + lj] = z[lj];
}
REAL(u1path)[l] = u1;
REAL(u2path)[l] = u2;
REAL(s1path)[l] = smin;
REAL(s2path)[l] = smax;
REAL(gpath)[l] = proposal_log_dens - current_log_dens;
}
if (accept) {
memcpy(state, proposal, dim_nc * sizeof(double));
current_log_dens = proposal_log_dens;
}
} /* end of inner loop (one iteration) */
outfun(state, out_buffer);
for (int j = 0; j < dim_out; j++)
batch_buffer[j] += out_buffer[j];
} /* end of middle loop (one batch) */
for (int j = 0; j < dim_out; j++, k++)
REAL(path)[k] = batch_buffer[j] / int_blen;
} /* end of outer loop */
PutRNGstate();
PROTECT(save_final = allocVector(REALSXP, dim_nc));
memcpy(REAL(save_final), state, dim_nc * sizeof(double));
SET_VECTOR_ELT(result, 2, save_final);
UNPROTECT(5);
return result;
}