int rmvnorm(const gsl_rng *r, const int n, const gsl_vector *mean,
const gsl_matrix *var, gsl_vector *result){
/* multivariate normal distribution random number generator */
/*
* n dimension of the random vetor
* mean vector of means of size n
* var variance matrix of dimension n x n
* result output variable with a sigle random vector normal distribution generation
*/
int k;
gsl_matrix *work = gsl_matrix_alloc(n,n);
gsl_matrix_memcpy(work,var);
gsl_linalg_cholesky_decomp(work);
for(k=0; k<n; k++)
gsl_vector_set( result, k, gsl_ran_ugaussian(r) );
gsl_blas_dtrmv(CblasLower, CblasNoTrans, CblasNonUnit, work, result );
gsl_vector_add(result,mean);
gsl_matrix_free(work);
return 0;
}
int gaussian_valid(const gaussian_t* dist) {
if (!(dist && dist->dim > 0 && dist->mean->size == dist->dim)) {
return 0;
}
// check positive definite
if (gaussian_isdiagonal(dist)) {
size_t i = 0;
for (i = 0; i < dist->dim; i++) {
double x = gsl_vector_get(dist->diag, i);
if (!isnormal(x) || x <= 0) {
return 0;
}
}
}
else {
gsl_matrix* v = gsl_matrix_alloc(dist->dim, dist->dim);
gsl_matrix_memcpy(v, dist->cov);
gsl_set_error_handler_off();
int status = gsl_linalg_cholesky_decomp(v);
gsl_set_error_handler(NULL);
gsl_matrix_free(v);
if (status == GSL_EDOM) {
return 0;
}
}
return 1;
}
void chol_inverse_cov_matrix(optstruct* options, gsl_matrix* temp_matrix, gsl_matrix* result_matrix, double* final_determinant_c){
int cholesky_test, i;
double determinant_c = 0.0;
gsl_error_handler_t *temp_handler; // disable the default handler
// do a cholesky decomp of the cov matrix, LU is not stable for ill conditioned matrices
temp_handler = gsl_set_error_handler_off();
cholesky_test = gsl_linalg_cholesky_decomp(temp_matrix);
if(cholesky_test == GSL_EDOM){
fprintf(stderr, "trying to cholesky a non postive def matrix, in emulate-fns.c sorry...\n");
exit(1);
}
gsl_set_error_handler(temp_handler);
// find the determinant and then invert
// the determinant is just the trace squared
determinant_c = 1.0;
for(i = 0; i < options->nmodel_points; i++)
determinant_c *= gsl_matrix_get(temp_matrix, i, i);
determinant_c = determinant_c * determinant_c;
//printf("det CHOL:%g\n", determinant_c);
gsl_linalg_cholesky_invert(temp_matrix);
gsl_matrix_memcpy(result_matrix, temp_matrix);
*final_determinant_c = determinant_c;
}
CAMLprim value ml_gsl_linalg_cholesky_decomp(value A)
{
_DECLARE_MATRIX(A);
_CONVERT_MATRIX(A);
gsl_linalg_cholesky_decomp(&m_A);
return Val_unit;
}
gsl_vector* linear_ols_beta(gsl_vector *v_y, gsl_matrix *m_X){
size_t i_k = m_X->size2;
gsl_vector *v_XTy = gsl_vector_alloc(i_k);
gsl_vector *v_betahat = gsl_vector_alloc(i_k);
gsl_matrix *m_XTX = gsl_matrix_alloc(i_k,i_k);
gsl_matrix *m_invXTX = gsl_matrix_alloc(i_k,i_k);
gsl_vector_set_all(v_XTy,0);
gsl_vector_set_all(v_betahat,0);
gsl_matrix_set_all(m_XTX,0);
olsg(v_y,m_X,v_XTy,m_XTX);
gsl_linalg_cholesky_decomp (m_XTX);
gsl_matrix_set_identity(m_invXTX);
gsl_blas_dtrsm (CblasLeft, CblasLower,CblasNoTrans,CblasNonUnit,1.0,m_XTX,m_invXTX);
gsl_blas_dtrsm (CblasLeft, CblasLower,CblasTrans,CblasNonUnit,1.0,m_XTX,m_invXTX);
gsl_vector_set_all(v_betahat,0.0);
gsl_blas_dsymv (CblasLower,1.0,m_invXTX,v_XTy,0.0,v_betahat);
gsl_vector_free(v_XTy);
gsl_matrix_free(m_XTX);
gsl_matrix_free(m_invXTX);
return v_betahat;
}
int GMRFLib_gsl_spd_inverse(gsl_matrix * A)
{
/*
* replace SPD matrix A with its inverse
*/
gsl_matrix *L;
gsl_vector *x;
size_t i, n;
assert(A->size1 == A->size2);
n = A->size1;
x = gsl_vector_calloc(n);
L = GMRFLib_gsl_duplicate_matrix(A);
gsl_linalg_cholesky_decomp(L);
for (i = 0; i < n; i++) {
gsl_vector_set_basis(x, i);
gsl_linalg_cholesky_svx(L, x);
gsl_matrix_set_col(A, i, x);
}
gsl_vector_free(x);
gsl_matrix_free(L);
return GMRFLib_SUCCESS;
}
void
gslu_rand_gaussian_matrix (const gsl_rng *r, gsl_matrix *A,
const gsl_vector *mu, const gsl_matrix *Sigma, const gsl_matrix *L)
{
assert (A->size1 == mu->size && (Sigma || L));
for (size_t i=0; i<A->size1; i++)
for (size_t j=0; j<A->size2; j++)
gsl_matrix_set (A, i, j, gsl_ran_gaussian_ziggurat (r, 1.0));
if (L) {
assert (L->size1 == L->size2 && L->size1 == mu->size);
gsl_blas_dtrmm (CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, 1.0, L, A);
}
else {
assert (Sigma->size1 == Sigma->size2 && Sigma->size1 == mu->size);
gsl_matrix *_L = gsl_matrix_alloc (Sigma->size1, Sigma->size2);
gsl_matrix_memcpy (_L, Sigma);
gsl_linalg_cholesky_decomp (_L);
gsl_blas_dtrmm (CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, 1.0, _L, A);
gsl_matrix_free (_L);
}
for (size_t j=0; j<A->size2; j++) {
gsl_vector_view a = gsl_matrix_column (A, j);
gsl_vector_add (&a.vector, mu);
}
}
void gaussian_gen(const gsl_rng* rng, const gaussian_t* dist,
gsl_vector* result) {
assert(result->size == dist->dim);
size_t i;
for (i = 0; i < result->size; i++) {
gsl_vector_set(result, i, gsl_ran_ugaussian(rng));
}
if (gaussian_isdiagonal(dist)) {
for (i = 0; i < result->size; i++) {
double* p = gsl_vector_ptr(result, i);
*p *= DEBUG_SQRT(gsl_vector_get(dist->diag, i));
}
}
else {
gsl_matrix* v = gsl_matrix_alloc(dist->dim, dist->dim);
gsl_matrix_memcpy(v, dist->cov);
gsl_linalg_cholesky_decomp(v);
gsl_blas_dtrmv(CblasLower, CblasNoTrans, CblasNonUnit, v, result);
gsl_matrix_free(v);
}
gsl_vector_add(result, dist->mean);
}
//Wishart distribution random number generator
int ran_wishart(const gsl_rng *r, const double nu,
const gsl_matrix *V, gsl_matrix *X)
{
const int k = V->size1;
int i, j;
gsl_matrix *A = gsl_matrix_calloc(k, k);
gsl_matrix *L = gsl_matrix_alloc(k, k);
for(i=0; i<k; i++)
{
gsl_matrix_set(A, i, i, sqrt(gsl_ran_chisq(r, (nu-i))));
for (j=0; j<i; j++){
gsl_matrix_set(A, i, j, gsl_ran_gaussian(r, 1));
}
}
gsl_matrix_memcpy(L, V);
gsl_linalg_cholesky_decomp(L);
gsl_blas_dtrmm(CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, 1.0, L, A);
gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, A, A, 0.0, X);
gsl_matrix_free(A);
gsl_matrix_free(L);
return 0;
}
double* paramTrans_LG(double *theta, int dx, int dy)
{
int i,k,s, npx=pow(dx,2), mpy=dy*dx;
int start1=dx+npx;
gsl_matrix *SIGMA=gsl_matrix_alloc(dx,dx);
double *param=(double*)malloc(sizeof(double)*(start1+npx));
//Store mux
for(k=0;k<dx;k++)
{
param[k]=theta[k];
}
//store A matrix
for(k=0;k<dx;k++)
{
for(s=0;s<dx;s++)
{
param[dx+dx*k+s]=theta[dx+dy+dx*k+s];
}
}
//store parameters for the variance
for(k=0;k<dx;k++)
{
for(s=0;s<dx;s++)
{
gsl_matrix_set(SIGMA,k,s,theta[dx+dy+npx+mpy+dx*k+s]);
}
}
gsl_linalg_cholesky_decomp(SIGMA);
for(k=0;k<dx-1;k++)
{
for(s=k+1;s<dx;s++)
{
gsl_matrix_set(SIGMA,k,s,0);
}
}
for(k=0;k<dx;k++)
{
for(s=0;s<dx;s++)
{
param[start1+dx*k+s]=gsl_matrix_get(SIGMA,k,s);
}
}
gsl_matrix_free(SIGMA);
SIGMA=NULL;
return(param);
}
// Inverse Wishart distribution random number generator
int ran_invwishart(const gsl_rng *r, const double nu,
const gsl_matrix *V, gsl_matrix *X)
{
const int k = V->size1;
gsl_matrix *Vinv = gsl_matrix_alloc(k, k);
gsl_matrix_memcpy(Vinv, V);
gsl_linalg_cholesky_decomp(Vinv);
gsl_linalg_cholesky_invert(Vinv);
ran_wishart(r, nu, Vinv, X);
gsl_linalg_cholesky_decomp(X);
gsl_linalg_cholesky_invert(X);
gsl_matrix_free(Vinv);
return 0;
}
int mcmclib_cholesky_decomp(gsl_matrix* A) {
gsl_error_handler_t *hnd = gsl_set_error_handler_off();
int status = gsl_linalg_cholesky_decomp(A);
gsl_set_error_handler(hnd);
if(status != GSL_SUCCESS)
return status;
return GSL_SUCCESS;
}
/* Update parameters using an implicit solver for
* equation (17) of Girolami and Calderhead (2011).
* Arguments:
* state: a pointer to internal working storage for RMHMC.
* model: a pointer to the rmhmc_model structure with pointers to user defined functions.
* N: number of parameters.
* stepSize: integration step-size.
* Result:
* The method directly updates the new_x array in the state structure.
* returns 0 for success or non-zero for failure.
*/
static int parametersNewtonUpdate(rmhmc_params* state, rmhmc_model* model, int N , double stepSize){
gsl_vector_view new_x_v = gsl_vector_view_array(state->new_x, N);
gsl_vector_view new_p_v = gsl_vector_view_array(state->new_momentum, N);
gsl_matrix_view new_cholM_v = gsl_matrix_view_array(state->new_cholMx, N, N);
/* temp copy of parameters */
gsl_vector_view x0_v = gsl_vector_view_array(state->btmp, N);
gsl_vector_memcpy(&x0_v.vector, &new_x_v.vector);
/* temp copy of inverse Metric */
gsl_matrix_view new_invM_v = gsl_matrix_view_array(state->new_invMx, N, N);
gsl_matrix_view invM0_v = gsl_matrix_view_array(state->tmpM, N, N);
gsl_matrix_memcpy(&invM0_v.matrix, &new_invM_v.matrix);
gsl_vector_view a_v = gsl_vector_view_array(state->atmp, N);
/* a = invM0*pNew */
/* TODO: replace gsl_blas_dgemv with gsl_blas_dsymv since invM0_v.matrix is symetric */
gsl_blas_dgemv(CblasNoTrans, 1.0, &invM0_v.matrix, &new_p_v.vector, 0.0, &a_v.vector);
int iterations = state->fIt;
int flag = 0;
int i;
for (i = 0; i < iterations; i++) {
/* new_x = invM_new*p_new */
/* TODO: replace gsl_blas_dgemv with gsl_blas_dsymv since inew_invM_v.matrix is symetric */
gsl_blas_dgemv(CblasNoTrans, 1.0, &new_invM_v.matrix, &new_p_v.vector, 0.0, &new_x_v.vector);
/* Calculates new_x_v = x0 + 0.5*stepSize*(invM_0*newP + newInvM*newP) */
gsl_vector_add(&new_x_v.vector, &a_v.vector);
gsl_vector_scale(&new_x_v.vector, 0.5*stepSize);
gsl_vector_add(&new_x_v.vector, &x0_v.vector);
/* calculate metric at the current position or update everything if this is the last iteration */
if ( (i == iterations-1) )
/* call user defined function for updating all quantities */
model->PosteriorAll(state->new_x, model->m_params, &state->new_fx, state->new_dfx, state->new_cholMx, state->new_dMx);
else
/* call user defined function for updating only the metric ternsor */
model->Metric(state->new_x, model->m_params, state->new_cholMx);
/* calculate cholesky factor for current metric */
gsl_error_handler_t* old_handle = gsl_set_error_handler_off();
flag = gsl_linalg_cholesky_decomp( &new_cholM_v.matrix );
if (flag != 0){
fprintf(stderr,"RMHMC: matrix not positive definite in parametersNewtonUpdate.\n");
return flag;
}
gsl_set_error_handler(old_handle);
/* calculate inverse for current metric */
gsl_matrix_memcpy(&new_invM_v.matrix, &new_cholM_v.matrix );
gsl_linalg_cholesky_invert(&new_invM_v.matrix);
}
return flag;
}
void mvn_sample(gsl_vector *mean_cand, gsl_matrix *var)
{
/* Takes a mean vec, mean and var matrix,
* var and gives vector of MVN(mean,var) realisations, x
*/
int i, j;
int dimen = var -> size1;
double value;
gsl_matrix *disp;
gsl_vector *ran;
gsl_matrix *fast_species;
fast_species = gsl_matrix_alloc(2, 2);
gsl_matrix_set_identity(fast_species);
for(i=0;i<dimen; i++) {
if(MGET(var, i, i) <0.00000000001) {
MSET(var, i, i, 1.0);
MSET(fast_species, i, i, 0.0);
}
}
disp = gsl_matrix_alloc(2, 2);
ran = gsl_vector_alloc(2);
gsl_matrix_memcpy(disp, var);
if(postive_definite == 1) {
gsl_linalg_cholesky_decomp(disp);
for(i=0;i<dimen;i++) {
for (j=i+1;j<dimen;j++) {
MSET(disp,i,j,0.0);
}
}
}else{
value = pow(MGET(disp, 0 ,0), 0.5);
gsl_matrix_set_identity(disp);
MSET(disp, 0,0, value);
MSET(disp, 1,1, value);
}
for (j=0;j<dimen;j++) {
VSET(ran,j,gsl_ran_gaussian(r,1.0));
}
/*remove update from slow species*/
gsl_matrix_mul_elements(disp, fast_species);
/*Add noise to mean cand*/
gsl_blas_dgemv(CblasNoTrans,1.0, disp, ran, 1.0, mean_cand);
for(i=0; i<2; i++) {
if(VGET(mean_cand,i)<=0.0001 && MGET(fast_species, i, i) > 0.000001)
VSET(mean_cand,i,0.0001);
}
gsl_vector_free(ran);
gsl_matrix_free(disp);
gsl_matrix_free(fast_species);
}
void RandomNumberGenerator::gaussian_mv(const vector<double> &mean, const vector<vector<double> > &covar, const vector<double> &min, const vector<double> &max, vector<double> &result){
/* multivariate normal distribution random number generator */
/*
* n dimension of the random vetor
* mean vector of means of size n
* var variance matrix of dimension n x n
* result output variable with a sigle random vector normal distribution generation
*/
int k;
int n=mean.size();
gsl_matrix *_covar = gsl_matrix_alloc(covar.size(),covar[0].size());
gsl_vector *_result = gsl_vector_calloc(mean.size());
gsl_vector *_mean = gsl_vector_calloc(mean.size());
result.resize(mean.size());
for(k=0;k<n;k++){
for(int j=0;j<n;j++){
gsl_matrix_set(_covar,k,j,covar[k][j]);
}
gsl_vector_set(_mean, k, mean[k]);
}
int status = gsl_linalg_cholesky_decomp(_covar);
if(status){
printf("ERROR: Covariance matrix appears to be un-invertible. Increase your convergence step length to better sample the posterior such that you have enough samples to create a non-singular matrix at first matrix update.\nExiting...\n");
exit(1);
}
bool in_range;
do{
for(k=0; k<n; k++)
gsl_vector_set( _result, k, gsl_ran_ugaussian(r) );
gsl_blas_dtrmv(CblasLower, CblasNoTrans, CblasNonUnit, _covar, _result);
gsl_vector_add(_result,_mean);
in_range = true;
for(k=0; k<n; k++){
if(gsl_vector_get(_result, k) < min[k] or gsl_vector_get(_result, k) > max[k]){
in_range = false;
k=n+1;
}
}
}while(not in_range);
for(k=0; k<n; k++){
result[k] = gsl_vector_get(_result, k);
}
gsl_matrix_free(_covar);
gsl_vector_free(_result);
gsl_vector_free(_mean);
return;
}
void simLinearGaussian(gsl_rng *random, int dx, int start1, int start2, int N, double *theta, double *x)
{
int i, s,k;
double *mu=(double*)malloc(sizeof(double)*dx);
double *wSim=(double*)malloc(sizeof(double)*dx);
gsl_matrix *SIGMA=gsl_matrix_alloc(dx,dx);
//mean
for(k=0;k<dx;k++)
{
mu[k]=theta[start1+k];
}
//Sigma
for(k=0;k<dx;k++)
{
for(s=0;s<dx;s++)
{
gsl_matrix_set(SIGMA,k,s,theta[start2+dx*k+s]);
}
}
gsl_linalg_cholesky_decomp(SIGMA);
for(k=0;k<dx-1;k++)
{
for(s=k+1;s<dx;s++)
{
gsl_matrix_set(SIGMA,k,s,0);
}
}
//Simulations
for(i=0;i<N;i++)
{
rmnorm(random,dx, mu, SIGMA,wSim);
for(k=0;k<dx;k++)
{
x[dx*i+k]=wSim[k];
}
}
free(wSim);
wSim=NULL;
free(mu);
mu=NULL;
gsl_matrix_free(SIGMA);
SIGMA=NULL;
}
int GlmTest::resampSmryCase(glm *model, gsl_matrix *bT, GrpMat *GrpXs, gsl_matrix *bO, unsigned int i )
{
gsl_set_error_handler_off();
int status, isValid=TRUE;
unsigned int j, k, id;
gsl_vector_view yj, oj, xj;
gsl_matrix *tXX = NULL;
unsigned int nRows=tm->nRows, nParam=tm->nParam;
if (bootID == NULL) {
tXX = gsl_matrix_alloc(nParam, nParam);
while (isValid==TRUE) { // if all isSingular==TRUE
if (tm->reprand!=TRUE) GetRNGstate();
for (j=0; j<nRows; j++) {
// resample Y, X, offsets accordingly
if (tm->reprand==TRUE)
id = (unsigned int) gsl_rng_uniform_int(rnd, nRows);
else id = (unsigned int) nRows * Rf_runif(0, 1);
xj = gsl_matrix_row(model->Xref, id);
gsl_matrix_set_row(GrpXs[0].matrix, j, &xj.vector);
yj = gsl_matrix_row(model->Yref, id);
gsl_matrix_set_row(bT, j, &yj.vector);
oj = gsl_matrix_row(model->Eta, id);
gsl_matrix_set_row(bO, j, &oj.vector);
}
if (tm->reprand!=TRUE) PutRNGstate();
gsl_matrix_set_identity(tXX);
gsl_blas_dsyrk(CblasLower,CblasTrans,1.0,GrpXs[0].matrix,0.0,tXX);
status=gsl_linalg_cholesky_decomp(tXX);
if (status!=GSL_EDOM) break;
// if (calcDet(tXX)>eps) break;
}
for (k=2; k<nParam+2; k++)
subX2(GrpXs[0].matrix, k-2, GrpXs[k].matrix);
}
else {
for (j=0; j<nRows; j++) {
id = (unsigned int) gsl_matrix_get(bootID, i, j);
// resample Y and X and offset
yj=gsl_matrix_row(model->Yref, id);
gsl_matrix_set_row (bT, j, &yj.vector);
oj = gsl_matrix_row(model->Eta, id);
gsl_matrix_set_row(bO, j, &oj.vector);
xj = gsl_matrix_row(model->Xref, id);
gsl_matrix_set_row(GrpXs[0].matrix, j, &xj.vector);
}
for (k=2; k<nParam+2; k++)
subX2(GrpXs[0].matrix, k-2, GrpXs[k].matrix);
}
gsl_matrix_free(tXX);
return SUCCESS;
}
double ran_invwishart_pdf(const gsl_matrix *X, const double nu, const gsl_matrix *V)
{
const int k = X->size1;
double den;
gsl_matrix *Xinv = gsl_matrix_alloc(k, k);
gsl_matrix *Vinv = gsl_matrix_alloc(k, k);
gsl_matrix_memcpy(Xinv, X);
gsl_matrix_memcpy(Vinv, V);
gsl_linalg_cholesky_decomp(Xinv);
gsl_linalg_cholesky_invert(Xinv);
gsl_linalg_cholesky_decomp(Vinv);
gsl_linalg_cholesky_invert(Vinv);
den = ran_wishart_pdf(Xinv, nu, Vinv);
gsl_matrix_free(Xinv);
gsl_matrix_free(Vinv);
return den;
}
//inverse of real (symmetric) positive defined matrix
//as a by-product we may obtain the square root of the determinant of A
int InvRPD(Matrix &R, Matrix &A, double *LogDetSqrt, Matrix *ExternChol) {
assert(A.nRow() == A.nCol());
assert(R.nRow() == R.nCol());
assert(A.nRow() == R.nCol());
Matrix *Chol;
//Make the auxiliar matrix equal to A
if (ExternChol == NULL)
Chol = new Matrix( A.nRow(), A.nCol());
else
Chol = ExternChol;
R.Iden(); //Make R the identity
Chol->copy(A);
//Chol->print("A=\n");
gsl_error_handler_t *hand = gsl_set_error_handler_off ();
int res = gsl_linalg_cholesky_decomp(Chol->Ma());
gsl_set_error_handler(hand);
if (res == GSL_EDOM) {
//printf("Matrix::InvRPD: Warning: Non positive definite matrix.\n"); //exit(0);
return 0;
}
assert(res != GSL_EDOM); //Check that everything went well
//solve for the cannonical vectors to obtain the inverse in R
for (int i=0; i<R.nRow(); i++)
{
//R.print("R=\n");
gsl_linalg_cholesky_svx( Chol->Ma(), R.AsColVec(i));
}
if (LogDetSqrt != NULL) {
*LogDetSqrt = 0.0;
for (int i=0; i<Chol->nRow(); i++) {
*LogDetSqrt += log(Chol->ele( i, i)); //multiply the diagonal elements
}
}
if (ExternChol == NULL)
delete Chol;
return 1;
}
//int GlmTest::resampAnovaCase(glm *model, gsl_matrix *Onull, gsl_matrix *bT, gsl_matrix *bX, gsl_matrix *bO, gsl_matrix *bOnull, unsigned int i)
int GlmTest::resampAnovaCase(glm *model, gsl_matrix *bT, gsl_matrix *bX, gsl_matrix *bO, unsigned int i)
{
gsl_set_error_handler_off();
int status, isValid=TRUE;
unsigned int j, id, nP;
gsl_vector_view yj, xj, oj;
nP = model->Xref->size2;
gsl_matrix *tXX = gsl_matrix_alloc(nP, nP);
unsigned int nRows=tm->nRows;
if (bootID == NULL) {
while (isValid==TRUE) {
if (tm->reprand!=TRUE) GetRNGstate();
for (j=0; j<nRows; j++) {
if (tm->reprand==TRUE)
id=(unsigned int)gsl_rng_uniform_int(rnd, nRows);
else id=(unsigned int) nRows*Rf_runif(0, 1);
// resample Y and X and offset
yj=gsl_matrix_row(model->Yref, id);
xj = gsl_matrix_row(model->Xref, id);
oj = gsl_matrix_row(model->Eta, id);
gsl_matrix_set_row (bT, j, &yj.vector);
gsl_matrix_set_row(bX, j, &xj.vector);
gsl_matrix_set_row(bO, j, &oj.vector);
}
if (tm->reprand!=TRUE) PutRNGstate();
gsl_matrix_set_identity(tXX);
gsl_blas_dsyrk(CblasLower,CblasTrans,1.0,bX,0.0,tXX);
status=gsl_linalg_cholesky_decomp(tXX);
if (status!=GSL_EDOM) break;
}
}
else {
for (j=0; j<nRows; j++) {
id = (unsigned int) gsl_matrix_get(bootID, i, j);
// resample Y and X and offset
yj=gsl_matrix_row(model->Yref, id);
xj = gsl_matrix_row(model->Xref, id);
oj = gsl_matrix_row(model->Oref, id);
gsl_matrix_set_row (bT, j, &yj.vector);
gsl_matrix_set_row(bX, j, &xj.vector);
gsl_matrix_set_row(bO, j, &oj.vector);
}
}
gsl_matrix_free(tXX);
return SUCCESS;
}
double* paramTrans_Neuro(double *t, int dx, int dy)
{
int i,k,s, npx=pow(dx,2), mpy=dy*dx;
int start1=dx+npx;
gsl_matrix *SIGMA=gsl_matrix_calloc(dx/2,dx/2);
double *param=(double*)malloc(sizeof(double)*(start1+npx/4));
//Store mux
for(k=0;k<dx;k++)
{
param[k]=t[k];
}
//store A matrix
for(k=0;k<dx;k++)
{
for(s=0;s<dx;s++)
{
param[dx+dx*k+s]=t[dx+dy+dx*k+s];
}
}
//store parameters for the variance
for(k=0;k<dx/2;k++)
{
gsl_matrix_set(SIGMA,k,k,t[dx+dy+npx+mpy+dx*k+k]);
}
gsl_linalg_cholesky_decomp(SIGMA);
for(k=0;k<dx/2;k++)
{
for(s=0;s<dx/2;s++)
{
param[start1+dx*k/2+s]=gsl_matrix_get(SIGMA,k,s);
}
}
gsl_matrix_free(SIGMA);
SIGMA=NULL;
return(param);
}
int isPositiveDefinite(gsl_matrix *A)
{
gsl_matrix *temp;
temp = gsl_matrix_alloc(A->size1, A->size2);
if (gsl_linalg_cholesky_decomp(temp) == GSL_EDOM) {
gsl_matrix_free(temp);
return MATRIX_NOT_POS_DEF;
}
gsl_matrix_free(temp);
return 0;
}
/**
* Compute the Cholesky decomposition of a matrix.
*
* A wrapper for gsl_linalg_cholesky_decomp() that avoids halting if the matrix
* is found not to be positive-definite. This often happens when decomposing a
* covariance matrix that is poorly estimated due to low sample size.
* @param mat The matrix to decompose (in place).
* @return Status of call to gsl_linalg_cholesky_decomp().
*/
INT4 LALInferenceCholeskyDecompose(gsl_matrix *mat) {
INT4 status;
/* Turn off default GSL error handling (i.e. aborting), and catch
* errors decomposing due to non-positive definite covariance matrices */
gsl_error_handler_t *default_gsl_error_handler =
gsl_set_error_handler_off();
status = gsl_linalg_cholesky_decomp(mat);
if (status) {
if (status != GSL_EDOM) {
fprintf(stderr, "ERROR: Unexpected problem \
Cholesky-decomposing matrix.\n");
exit(-1);
}
}
// f = (1/2) x^T Ax + b^T x
void prox_quad(gsl_vector *x, const double rho, gsl_matrix *A, gsl_matrix *b)
{
gsl_matrix *I = gsl_matrix_alloc(A->size1);
gsl_matrix_set_identity(I);
gsl_matrix_scale(I, rho);
gsl_matrix_add(I, A);
gsl_vector_scale(x, rho);
gsl_vector_scale(b, -1);
gsl_vector_add(b, x);
gsl_linalg_cholesky_decomp(I);
gsl_linalg_cholesky_solve(I, b, x);
gsl_matrix_free(I);
}
int rmvnorm(const gsl_rng *r, const unsigned int n, const gsl_matrix *Sigma, gsl_vector *randeffect)
{
unsigned int k;
gsl_matrix *work = gsl_matrix_alloc(n,n);
gsl_matrix_memcpy(work, Sigma);
gsl_linalg_cholesky_decomp(work);
for(k=0; k<n; k++)
gsl_vector_set(randeffect, k, gsl_ran_ugaussian(r) );
gsl_blas_dtrmv(CblasLower, CblasNoTrans, CblasNonUnit, work, randeffect);
gsl_matrix_free(work);
return 0;
}
int rwishart(const gsl_rng *r, const unsigned int n, const unsigned int dof, const gsl_matrix *scale, gsl_matrix *result)
{
unsigned int k,l;
gsl_matrix *work = gsl_matrix_calloc(n,n);
for(k=0; k<n; k++){
gsl_matrix_set( work, k, k, sqrt( gsl_ran_chisq( r, (dof-k) ) ) );
for(l=0; l<k; l++)
gsl_matrix_set( work, k, l, gsl_ran_ugaussian(r) );
}
gsl_matrix_memcpy(result,scale);
gsl_linalg_cholesky_decomp(result);
gsl_blas_dtrmm(CblasLeft,CblasLower,CblasNoTrans,CblasNonUnit,1.0,result,work);
gsl_blas_dsyrk(CblasUpper,CblasNoTrans,1.0,work,0.0,result);
return 0;
}
int main() {
int ret;
gsl_matrix A;
double data[9];
int i, j;
memset(&A, 0, sizeof(gsl_matrix));
A.size1 = 3;
A.size2 = 3;
A.tda = 3;
A.data = data;
gsl_matrix_set(&A, 0, 0, 34.0);
gsl_matrix_set(&A, 0, 1, 4.0);
gsl_matrix_set(&A, 0, 2, 14.0);
gsl_matrix_set(&A, 1, 0, 1.0);
gsl_matrix_set(&A, 1, 1, 8.0);
gsl_matrix_set(&A, 1, 2, 3.0);
gsl_matrix_set(&A, 2, 0, 7.0);
gsl_matrix_set(&A, 2, 1, 1.0);
gsl_matrix_set(&A, 2, 2, 8.0);
for (i=0; i<A.size1; i++) {
printf((i==0) ? "A = (" : " (");
for (j=0; j<A.size2; j++) {
printf(" %12.5g ", gsl_matrix_get(&A, i, j));
}
printf(")\n");
}
printf("\n");
ret = gsl_linalg_cholesky_decomp(&A);
for (i=0; i<A.size1; i++) {
printf((i==0) ? "L = (" : " (");
for (j=0; j<A.size2; j++) {
printf(" %12.5g ", (j <= i) ? gsl_matrix_get(&A, i, j) : 0.0);
}
printf(")\n");
}
printf("\n");
return 0;
}
/* Initialise RMHMC kernel with initial parameters x.
* Arguments:
* kernel: a pointer to the RMHMC kernel structure.
* x: an array of N doubles with initial parameters. N must be
* equal to kernel->N.
* Result:
* returns 0 for success and non-zero for error.
*/
static int rmhmc_kernel_init(mcmc_kernel* kernel, const double* x){
int res,i,n;
n = kernel->N;
rmhmc_params* params = (rmhmc_params*)kernel->kernel_params;
/* copy x to the kernel x state */
for ( i=0; i < n; i++)
kernel->x[i] = x[i];
rmhmc_model* model = kernel->model_function;
/* call user function to update all required quantities */
res = model->PosteriorAll(x, model->m_params, &(params->fx), params->dfx, params->cholMx, params->dMx);
/* TODO: write a proper error handler */
if (res != 0){
fprintf(stderr,"rmhmc_kernel_init: Likelihood function failed\n");
return 1;
}
/* calculate cholesky factor for current metric */
gsl_matrix_view cholMx_v = gsl_matrix_view_array(params->cholMx,n,n);
gsl_error_handler_t* old_handle = gsl_set_error_handler_off();
res = gsl_linalg_cholesky_decomp( &cholMx_v.matrix );
if (res != 0){
fprintf(stderr,"Error: matrix not positive definite in rmhmc_init.\n");
return -1;
}
gsl_set_error_handler(old_handle);
/* calculate inverse for current metric */
gsl_matrix_view invMx_v = gsl_matrix_view_array(params->invMx,n,n);
gsl_matrix_memcpy(&invMx_v.matrix, &cholMx_v.matrix );
gsl_linalg_cholesky_invert(&invMx_v.matrix);
/* calculate trace terms from equation (15) in Girolami and Calderhead (2011) */
calculateTraceTerms(n, params->invMx, params->dMx, params->tr_invM_dM);
return 0;
}
int
gsl_eigen_gensymm (gsl_matrix * A, gsl_matrix * B, gsl_vector * eval,
gsl_eigen_gensymm_workspace * w)
{
const size_t N = A->size1;
/* check matrix and vector sizes */
if (N != A->size2)
{
GSL_ERROR ("matrix must be square to compute eigenvalues", GSL_ENOTSQR);
}
else if ((N != B->size1) || (N != B->size2))
{
GSL_ERROR ("B matrix dimensions must match A", GSL_EBADLEN);
}
else if (eval->size != N)
{
GSL_ERROR ("eigenvalue vector must match matrix size", GSL_EBADLEN);
}
else if (w->size != N)
{
GSL_ERROR ("matrix size does not match workspace", GSL_EBADLEN);
}
else
{
int s;
/* compute Cholesky factorization of B */
s = gsl_linalg_cholesky_decomp(B);
if (s != GSL_SUCCESS)
return s; /* B is not positive definite */
/* transform to standard symmetric eigenvalue problem */
gsl_eigen_gensymm_standardize(A, B);
s = gsl_eigen_symm(A, eval, w->symm_workspace_p);
return s;
}
} /* gsl_eigen_gensymm() */
int ran_mv_t(const gsl_rng *r, const gsl_vector *mu,
const gsl_matrix *Sigma, const double nu, gsl_vector *x)
{
const int k = mu->size;
gsl_matrix *A = gsl_matrix_alloc(k, k);
double v;
v = gsl_ran_chisq(r, nu);
gsl_matrix_memcpy(A, Sigma);
gsl_linalg_cholesky_decomp(A);
ran_mv_normal(r, mu, Sigma, x);
gsl_blas_dtrmv(CblasLower, CblasNoTrans, CblasNonUnit, A, x);
gsl_vector_scale(x, 1/sqrt(v));
gsl_vector_add(x, mu);
gsl_matrix_free(A);
return 0;
}
