/**
* Integrate SDDE one step forward for a given vector field
* and state using the Euler Maruyama scheme.
* \param[in] field Delayed vector fields to evaluate.
* \param[in] stocField stochastic vector field to evaluate.
* \param[in/out] currentState Current state to update by one time step.
*/
void
EulerMaruyamaSDDE::stepForward(vectorFieldDelay *delayedField,
vectorFieldStochastic *stocField,
gsl_matrix *currentState)
{
// Assign pointers to workspace vectors
gsl_vector_view tmp = gsl_matrix_row(work, 0);
gsl_vector_view tmp1 = gsl_matrix_row(work, 1);
gsl_vector_view presentState;
/** Evaluate drift */
delayedField->evalField(currentState, &tmp.vector);
// Scale by time step
gsl_vector_scale(&tmp.vector, dt);
/** Update historic */
updateHistoric(currentState);
// Assign pointer to present state
presentState = gsl_matrix_row(currentState, 0);
// Evaluate stochastic field at present state
stocField->evalField(&presentState.vector, &tmp1.vector);
// Scale by time step
gsl_vector_scale(&tmp1.vector, sqrt(dt));
// Add drift to present state
gsl_vector_add(&presentState.vector, &tmp.vector);
/** Add diffusion at present state */
gsl_vector_add(&presentState.vector, &tmp1.vector);
return;
}
static int
robust_covariance(const double sigma, gsl_matrix *cov,
gsl_multifit_robust_workspace *w)
{
int s = 0;
const size_t p = w->p;
const double s2 = sigma * sigma;
size_t i, j;
gsl_matrix *QSI = w->QSI;
gsl_vector *D = w->D;
/* Form variance-covariance matrix cov = s2 * (Q S^-1) (Q S^-1)^T */
for (i = 0; i < p; i++)
{
gsl_vector_view row_i = gsl_matrix_row (QSI, i);
double d_i = gsl_vector_get (D, i);
for (j = i; j < p; j++)
{
gsl_vector_view row_j = gsl_matrix_row (QSI, j);
double d_j = gsl_vector_get (D, j);
double s;
gsl_blas_ddot (&row_i.vector, &row_j.vector, &s);
gsl_matrix_set (cov, i, j, s * s2 / (d_i * d_j));
gsl_matrix_set (cov, j, i, s * s2 / (d_i * d_j));
}
}
return s;
} /* robust_covariance() */
void update_phi(int doc_number, int time,
lda_post* p, lda_seq* var,
gsl_matrix* g) {
int i, k, n, K = p->model->ntopics, N = p->doc->nterms;
double dig[p->model->ntopics];
for (k = 0; k < K; k++) {
dig[k] = gsl_sf_psi(vget(p->gamma, k));
}
for (n = 0; n < N; n++) {
// compute log phi up to a constant
int w = p->doc->word[n];
for (k = 0; k < K; k++) {
mset(p->log_phi, n, k,
dig[k] + mget(p->model->topics, w, k));
}
// normalize in log space
gsl_vector log_phi_row = gsl_matrix_row(p->log_phi, n).vector;
gsl_vector phi_row = gsl_matrix_row(p->phi, n).vector;
log_normalize(&log_phi_row);
for (i = 0; i < K; i++) {
vset(&phi_row, i, exp(vget(&log_phi_row, i)));
}
}
}
static int
secs2d_eval_B(const double r, const double theta, const double phi,
double B[3], void * vstate)
{
secs2d_state_t *state = (secs2d_state_t *) vstate;
gsl_vector_view vx = gsl_matrix_row(state->X, 0);
gsl_vector_view vy = gsl_matrix_row(state->X, 1);
gsl_vector_view vz = gsl_matrix_row(state->X, 2);
(void) phi; /* unused parameter */
B[0] = 0.0;
B[1] = 0.0;
B[2] = 0.0;
if (state->flags & MAGFIT_SECS_FLG_FIT_DF)
{
secs2d_matrix_row_df(r, theta, phi, &vx.vector, &vy.vector, &vz.vector, state);
gsl_blas_ddot(&vx.vector, state->c, &B[0]);
gsl_blas_ddot(&vy.vector, state->c, &B[1]);
gsl_blas_ddot(&vz.vector, state->c, &B[2]);
}
if (state->flags & MAGFIT_SECS_FLG_FIT_CF)
{
secs2d_matrix_row_cf(r, theta, &vy.vector, state);
gsl_blas_ddot(&vy.vector, state->c, &B[1]);
}
return 0;
}
int
gsl_multifit_wlinear (const gsl_matrix * X,
const gsl_vector * w,
const gsl_vector * y,
gsl_vector * c,
gsl_matrix * cov,
double *chisq, gsl_multifit_linear_workspace * work)
{
int status;
size_t rank = 0;
double rnorm, snorm;
gsl_vector_view b = gsl_vector_subvector(work->t, 0, y->size);
/* compute A = sqrt(W) X, b = sqrt(W) y */
status = gsl_multifit_linear_applyW(X, w, y, work->A, &b.vector);
if (status)
return status;
/* compute SVD of A */
status = gsl_multifit_linear_bsvd(work->A, work);
if (status)
return status;
status = multifit_linear_solve(X, &b.vector, GSL_DBL_EPSILON, 0.0, &rank,
c, &rnorm, &snorm, work);
if (status)
return status;
*chisq = rnorm * rnorm;
/* variance-covariance matrix cov = s2 * (Q S^-1) (Q S^-1)^T */
{
const size_t p = X->size2;
size_t i, j;
gsl_matrix_view QSI = gsl_matrix_submatrix(work->QSI, 0, 0, p, p);
gsl_vector_view D = gsl_vector_subvector(work->D, 0, p);
for (i = 0; i < p; i++)
{
gsl_vector_view row_i = gsl_matrix_row (&QSI.matrix, i);
double d_i = gsl_vector_get (&D.vector, i);
for (j = i; j < p; j++)
{
gsl_vector_view row_j = gsl_matrix_row (&QSI.matrix, j);
double d_j = gsl_vector_get (&D.vector, j);
double s;
gsl_blas_ddot (&row_i.vector, &row_j.vector, &s);
gsl_matrix_set (cov, i, j, s / (d_i * d_j));
gsl_matrix_set (cov, j, i, s / (d_i * d_j));
}
}
}
return GSL_SUCCESS;
}
/**
* Integrate one step forward for a given vector field and state
* using the Runge-Kutta 4 scheme.
* \param[in] field Vector field to evaluate.
* \param[in,out] currentState Current state to update by one time step.
*/
void
RungeKutta4::stepForward(vectorField *field, gsl_vector *currentState)
{
/** Use views on a working matrix not to allocate memory
* at each time step */
gsl_vector_view k1, k2, k3, k4, tmp;
// Assign views
tmp = gsl_matrix_row(work, 0);
k1 = gsl_matrix_row(work, 1);
k2 = gsl_matrix_row(work, 2);
k3 = gsl_matrix_row(work, 3);
k4 = gsl_matrix_row(work, 4);
// First increament
field->evalField(currentState, &k1.vector);
gsl_vector_scale(&k1.vector, dt);
gsl_vector_memcpy(&tmp.vector, &k1.vector);
gsl_vector_scale(&tmp.vector, 0.5);
gsl_vector_add(&tmp.vector, currentState);
// Second increment
field->evalField(&tmp.vector, &k2.vector);
gsl_vector_scale(&k2.vector, dt);
gsl_vector_memcpy(&tmp.vector, &k2.vector);
gsl_vector_scale(&tmp.vector, 0.5);
gsl_vector_add(&tmp.vector, currentState);
// Third increment
field->evalField(&tmp.vector, &k3.vector);
gsl_vector_scale(&k3.vector, dt);
gsl_vector_memcpy(&tmp.vector, &k3.vector);
gsl_vector_add(&tmp.vector, currentState);
// Fourth increment
field->evalField(&tmp.vector, &k4.vector);
gsl_vector_scale(&k4.vector, dt);
gsl_vector_scale(&k2.vector, 2);
gsl_vector_scale(&k3.vector, 2);
gsl_vector_memcpy(&tmp.vector, &k1.vector);
gsl_vector_add(&tmp.vector, &k2.vector);
gsl_vector_add(&tmp.vector, &k3.vector);
gsl_vector_add(&tmp.vector, &k4.vector);
gsl_vector_scale(&tmp.vector, 1. / 6);
// Update state
gsl_vector_add(currentState, &tmp.vector);
return;
}
void Compute_Forces(gsl_matrix * Positions, gsl_matrix * Velocities, gsl_matrix * Neighbors,
gsl_vector * ListHead, gsl_vector * List, int type1, int type2,
gsl_matrix * Forces, gsl_vector * Energy, gsl_vector * Kinetic )
{
// RESET MATRICES AND VECTORS
// TODO: Redundant?
gsl_matrix_set_zero(Forces);
gsl_vector_set_zero(Energy);
gsl_vector_set_zero(Kinetic);
// Begin of parallel region
int omp_get_max_threads();
int chunks = NParticles / omp_get_max_threads();
#pragma omp parallel
{
#pragma omp for schedule (dynamic,chunks)
for (int i=0;i<NParticles;i++)
{
gsl_vector_view vi = gsl_matrix_row(Velocities, i);
double * fij = malloc(3*sizeof(double));
// Compute the kinetic energy of particle i (0.5 mi vi^2)
double ei = KineticEnergy(&vi.vector, (int) gsl_matrix_get(Positions,i,0));
gsl_vector_set(Kinetic,i,ei);
// Obtain the list of neighboring cells to iCell (the cell i belongs to)
int iCell = FindParticle(Positions,i);
gsl_vector_view NeighboringCells = gsl_matrix_row(Neighbors, iCell);
// Obtain the list of neighboring particles that interacts with i
// i interacts with all Verlet[j] particles (j = 0 .. NNeighbors-1)
int * Verlet = malloc(27 * NParticles * sizeof(int) / (Mx*My*Mz));
int NNeighbors = Compute_VerletList(Positions, i, &NeighboringCells.vector, iCell, ListHead, List, Verlet);
// Loop over all the j-neighbors of i-particle
for (int j=0;j<NNeighbors;j++)
{
ei = Compute_Force_ij(Positions, i, Verlet[j], type1, type2, fij);
Forces->data[i*Forces->tda + 0] += fij[0];
Forces->data[i*Forces->tda + 1] += fij[1];
Forces->data[i*Forces->tda + 2] += fij[2];
Energy->data[i*Energy->stride] += ei;
}
free(Verlet);
free(fij);
}
}
// End of parallel region
}
double fit_lda_post(int doc_number, int time,
lda_post* p, lda_seq* var,
gsl_matrix* g,
gsl_matrix* g3_matrix,
gsl_matrix* g4_matrix,
gsl_matrix* g5_matrix) {
init_lda_post(p);
gsl_vector_view topic_view;
gsl_vector_view renormalized_topic_view;
if (FLAGS_model == "fixed" && var && var->influence) {
// Make sure this stays in scope while the posterior is in
// use!
topic_view = gsl_matrix_row(
var->influence->doc_weights[time], doc_number);
renormalized_topic_view = gsl_matrix_row(
var->influence->renormalized_doc_weights[time], doc_number);
p->doc_weight = &topic_view.vector;
p->renormalized_doc_weight = &renormalized_topic_view.vector;
}
double lhood = compute_lda_lhood(p);
double lhood_old = 0;
double converged = 0;
int iter = 0;
do {
iter++;
lhood_old = lhood;
update_gamma(p);
if (FLAGS_model == "fixed" && var != NULL) {
update_phi_fixed(doc_number,
time,
p,
var,
g3_matrix,
g4_matrix,
g5_matrix);
} else if (FLAGS_model == "dtm" || var == NULL) {
update_phi(doc_number, time, p, var, g);
} else {
printf("Error. Unhandled model.\n");
exit(1);
}
// TODO(sgerrish): Remove this.
// output_phi(p);
lhood = compute_lda_lhood(p);
converged = fabs((lhood_old - lhood) /
(lhood_old * p->doc->total));
} while ((converged > LDA_INFERENCE_CONVERGED) &&
(iter <= LDA_INFERENCE_MAX_ITER));
return(lhood);
}
void ica_match_gt(gsl_matrix *true_a, gsl_matrix *true_s,
gsl_matrix *esti_a, gsl_matrix *esti_s){
/* Sort estimated loading and source matrices to match
ground truth*/
const size_t NCOMP = true_s->size1;
const size_t NVOX = true_s->size2;
const size_t NSUB = true_a->size1;
gsl_matrix *cs = gsl_matrix_alloc(NCOMP, NCOMP);
// cs <- CORR(S, S')
matrix_cross_corr_row(cs, true_s, esti_s);
matrix_apply_all(cs, absolute);
// index <- cs.max(axis = 1 );
size_t i;
gsl_vector_view a_row, b_row;
gsl_vector *index = gsl_vector_alloc(NCOMP);
for (i = 0; i < NCOMP; i++) {
a_row = gsl_matrix_row(cs, i);
gsl_vector_set(index, i,
gsl_stats_max_index(a_row.vector.data,
a_row.vector.stride,
a_row.vector.size));
}
// Sort estimated sources
// S' <- S'[index,:]
gsl_matrix *temp = gsl_matrix_alloc(NCOMP, NVOX);
gsl_matrix_memcpy(temp, esti_s);
#pragma omp parallel for private(i,a_row,b_row)
for (i = 0; i < NCOMP; i++) {
a_row = gsl_matrix_row(esti_s, i);
b_row = gsl_matrix_row(temp, gsl_vector_get(index, i));
gsl_vector_memcpy(&a_row.vector, &b_row.vector);
}
gsl_matrix_free(temp);
// Sort estimated loadings
// A' <- A'[:,index]
temp = gsl_matrix_alloc(NSUB, NCOMP);
gsl_matrix_memcpy(temp, esti_a);
#pragma omp parallel for private(i,a_row,b_row)
for (i = 0; i < NCOMP; i++) {
a_row = gsl_matrix_column(esti_a, i);
b_row = gsl_matrix_column(temp, gsl_vector_get(index, i));
gsl_vector_memcpy(&a_row.vector, &b_row.vector);
}
gsl_matrix_free(temp);
gsl_matrix_free(cs);
gsl_vector_free(index);
}
void gsl_matrix_normalize_rows(gsl_matrix * mat, struct scaling * scales){
if(scales == NULL){
for(unsigned i =0; i<mat->size2; i++){
gsl_vector_view row = gsl_matrix_row(mat, i);
gsl_vector_normalize(&row.vector);
}
} else {
for(unsigned i =0; i<mat->size2; i++){
gsl_vector_view row = gsl_matrix_row(mat, i);
scales[i] = gsl_vector_normalize(&row.vector);
}
}
}
/**
* Update past states of historic by one time step.
* \param[in/out] currentState Historic to update.
*/
void numericalSchemeSDDE::updateHistoric(gsl_matrix *currentState)
{
gsl_vector_view delayedState, afterState;
size_t delayMax = currentState->size1 - 1;
for (size_t d = 0; d < delayMax; d++)
{
delayedState = gsl_matrix_row(currentState, delayMax - d);
afterState = gsl_matrix_row(currentState, delayMax - d - 1);
gsl_vector_memcpy(&delayedState.vector, &afterState.vector);
}
return;
}
void matrix_cross_corr_row(gsl_matrix *C, gsl_matrix *A, gsl_matrix *B){
size_t i,j;
gsl_vector_view a, b;
double c;
#pragma omp parallel for private(i,j,a,b,c)
for (i = 0; i < A->size1; i++) {
for (j = 0; j < B->size1; j++) {
a = gsl_matrix_row(A, i);
b = gsl_matrix_row(B, j);
c = gsl_stats_correlation(a.vector.data, a.vector.stride, b.vector.data, b.vector.stride, a.vector.size);
gsl_matrix_set(C, i,j, c);
}
}
}
// simplex reduction
void reduction(double f(gsl_vector* x), simplex_workspace* W)
{
int i,k, m = W->n+1;
double ki, loi;
gsl_vector_view v;
// reduce vertices
for(i=0; i < W->n; i++)
{
loi = gsl_matrix_get(W->simplex,W->lo,i);
for(k = 0; k < m; k++)
{
if(k != W->lo)
{
ki = gsl_matrix_get(W->simplex,k,i);
gsl_matrix_set(W->simplex,k,i,0.5*(loi+ki));
}
}
}
// recalculate function values in affected vertices
for(i=0; i < m; i++)
{
if (i != W->lo)
{
v = gsl_matrix_row(W->simplex,i);
gsl_vector_set(W->fp,i,f(&v.vector));
}
}
return;
}
void mcmclib_matrix_printf(gsl_matrix* A) {
size_t n = A->size1;
for(size_t i=0; i<n; i++) {
gsl_vector_view row = gsl_matrix_row(A, i);
mcmclib_vector_printf(&row.vector);
}
}
/**
* emulate the model at the ith entry in results->new_x
*/
void emulate_ith_location(modelstruct *the_model, optstruct *options, resultstruct *results,int i, gsl_matrix* h_matrix, gsl_matrix* cinverse, gsl_vector *beta_vector){
double kappa;
double temp_mean, temp_var;
gsl_vector_view new_x_row;
gsl_vector *kplus = gsl_vector_alloc(options->nmodel_points);
gsl_vector *h_vector = gsl_vector_alloc(options->nregression_fns);
// read the new x location
new_x_row = gsl_matrix_row(results->new_x, i);
//fprintf(stderr, "i(%d) new_x_row: ", i);
//print_vector_quiet(&new_x_row.vector, options->nparams);
makeKVector(kplus, the_model->xmodel, &new_x_row.vector, the_model->thetas, options->nmodel_points, options->nthetas, options->nparams);
makeHVector(h_vector, &new_x_row.vector, options->nparams);
temp_mean = makeEmulatedMean(cinverse, the_model->training_vector, kplus, h_vector, h_matrix, beta_vector, options->nmodel_points);
kappa = covariance_fn(&new_x_row.vector, &new_x_row.vector, the_model->thetas, options->nthetas, options->nparams);
temp_var = makeEmulatedVariance(cinverse, kplus, h_vector, h_matrix, kappa, options->nmodel_points, options->nregression_fns);
//fprintf(stderr, "temp_mean %lf\ttemp_var %lf\n", temp_mean, temp_var);
gsl_vector_set(results->emulated_mean, i, temp_mean);
gsl_vector_set(results->emulated_var, i, temp_var);
gsl_vector_free(kplus);
gsl_vector_free(h_vector);
}
int wrap_gsl_linalg_SV_decomp(gsl_matrix* A, gsl_matrix* V, gsl_matrix* S,
gsl_matrix* work)
{
gsl_vector_view _S = gsl_matrix_diagonal(S);
gsl_vector_view _work = gsl_matrix_row(work, 0);
return gsl_linalg_SV_decomp(A, V, &_S.vector, &_work.vector);
}
/**
* Integrate the SDDE model forward for a given period.
* \param[in] length Duration of the integration.
* \param[in] Spinup Initial integration period to remove.
* \param[in] sampling Time step at which to save states.
* \return Matrix to record the states.
*/
gsl_matrix *
modelSDDE::integrateForward(const double length, const double spinup,
const size_t sampling)
{
size_t nt = length / scheme->getTimeStep();
size_t ntSpinup = spinup / scheme->getTimeStep();
gsl_matrix *data = gsl_matrix_alloc((size_t) ((nt - ntSpinup) / sampling), dim);
gsl_vector_view presentState;
// Get spinup
for (size_t i = 1; i <= ntSpinup; i++)
{
// Integrate one step forward
stepForward();
}
// Get record
for (size_t i = ntSpinup+1; i <= nt; i++)
{
// Integrate one step forward
stepForward();
// Save present state
if (i%sampling == 0)
{
presentState = gsl_matrix_row(currentState, 0);
gsl_matrix_set_row(data, (i - ntSpinup) / sampling - 1,
&presentState.vector);
}
}
return data;
}
int PoissonGlm::update(gsl_vector *bj, unsigned int id)
{
int isValid=TRUE;
unsigned int i;
double eij, mij;
gsl_vector_view xi;
for (i=0; i<nRows; i++) {
xi = gsl_matrix_row (Xref, i);
gsl_blas_ddot (&xi.vector, bj, &eij);
if (Oref!=NULL)
eij = eij+gsl_matrix_get(Oref, i, id);
if (eij>link(maxtol)) { // to avoid nan;
eij = link(maxtol);
isValid=FALSE;
}
if (eij<link(mintol)){
eij = link(mintol);
isValid=FALSE;
}
mij = invLink(eij);
gsl_matrix_set(Eta, i, id, eij);
gsl_matrix_set(Mu, i, id, mij);
}
return isValid;
}
static int
wnlin_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(wnlin_J, wnlin_N, wnlin_P);
double A = gsl_vector_get (x, 0);
double lambda = gsl_vector_get (x, 1);
size_t i;
for (i = 0; i < wnlin_N; i++)
{
gsl_vector_view v = gsl_matrix_row(&J.matrix, i);
double ti = i;
double swi = sqrt(wnlin_W[i]);
double e = exp(-lambda * ti);
gsl_vector_set(&v.vector, 0, e);
gsl_vector_set(&v.vector, 1, -ti * A * e);
gsl_vector_set(&v.vector, 2, 1.0);
gsl_vector_scale(&v.vector, swi);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
return GSL_SUCCESS;
}
int
gsl_linalg_balance_accum(gsl_matrix *A, gsl_vector *D)
{
const size_t N = A->size1;
if (N != D->size)
{
GSL_ERROR ("vector must match matrix size", GSL_EBADLEN);
}
else
{
size_t i;
double s;
gsl_vector_view r;
for (i = 0; i < N; ++i)
{
s = gsl_vector_get(D, i);
r = gsl_matrix_row(A, i);
gsl_blas_dscal(s, &r.vector);
}
return GSL_SUCCESS;
}
} /* gsl_linalg_balance_accum() */
/**
* Evaluate the delayed vector field from fields for each delay.
* \param[in] state State at which to evaluate the vector field.
* \param[out] field Vector resulting from the evaluation of the vector field.
*/
void
vectorFieldDelay::evalField(gsl_matrix *state, gsl_vector *field)
{
gsl_vector_view delayedState;
unsigned int delay;
// Set field evaluation to 0
gsl_vector_set_zero(field);
/** Add delayed drifts */
for (size_t d = 0; d < nDelays; d++)
{
delay = gsl_vector_uint_get(delays, nDelays - d - 1);
// Assign pointer to delayed state
delayedState = gsl_matrix_row(state, delay);
// Evaluate vector field at delayed state
fields->at(nDelays - d - 1)->evalField(&delayedState.vector, work);
// Add to newState in workspace
gsl_vector_add(field, work);
}
return;
}
void expectation(corpus* corpus, llna_model* model, llna_ss* ss,
double* avg_niter, double* total_lhood,
gsl_matrix* corpus_lambda, gsl_matrix* corpus_nu,
gsl_matrix* corpus_phi_sum,
short reset_var, double* converged_pct)
{
int i;
llna_var_param* var;
doc doc;
double lhood, total;
gsl_vector lambda, nu;
gsl_vector* phi_sum;
*avg_niter = 0.0;
*converged_pct = 0;
phi_sum = gsl_vector_alloc(model->k);
total = 0;
for (i = 0; i < corpus->ndocs; i++)
{
printf("doc %5d ", i);
doc = corpus->docs[i];
var = new_llna_var_param(doc.nterms, model->k);
if (reset_var)
init_var_unif(var, &doc, model);
else
{
lambda = gsl_matrix_row(corpus_lambda, i).vector;
nu= gsl_matrix_row(corpus_nu, i).vector;
init_var(var, &doc, model, &lambda, &nu);
}
lhood = var_inference(var, &doc, model);
update_expected_ss(var, &doc, ss);
total += lhood;
printf("lhood %5.5e niter %5d\n", lhood, var->niter);
*avg_niter += var->niter;
*converged_pct += var->converged;
gsl_matrix_set_row(corpus_lambda, i, var->lambda);
gsl_matrix_set_row(corpus_nu, i, var->nu);
col_sum(var->phi, phi_sum);
gsl_matrix_set_row(corpus_phi_sum, i, phi_sum);
free_llna_var_param(var);
}
gsl_vector_free(phi_sum);
*avg_niter = *avg_niter / corpus->ndocs;
*converged_pct = *converged_pct / corpus->ndocs;
*total_lhood = total;
}
inline static void
apply_givens_lq (size_t M, size_t N, gsl_matrix * Q, gsl_matrix * L,
size_t i, size_t j, double c, double s)
{
size_t k;
/* Apply rotation to matrix Q, Q' = G Q */
#if USE_BLAS
{
gsl_matrix_view Q0M = gsl_matrix_submatrix(Q,0,0,j+1,M);
gsl_vector_view Qi = gsl_matrix_row(&Q0M.matrix,i);
gsl_vector_view Qj = gsl_matrix_row(&Q0M.matrix,j);
gsl_blas_drot(&Qi.vector, &Qj.vector, c, -s);
}
#else
for (k = 0; k < M; k++)
{
double qik = gsl_matrix_get (Q, i, k);
double qjk = gsl_matrix_get (Q, j, k);
gsl_matrix_set (Q, i, k, qik * c - qjk * s);
gsl_matrix_set (Q, j, k, qik * s + qjk * c);
}
#endif
/* Apply rotation to matrix L, L' = L G^T (note: lower triangular so
zero for column > row) */
#if USE_BLAS
{
k = GSL_MIN(i,j);
gsl_matrix_view L0 = gsl_matrix_submatrix(L, k, 0, N-k, j+1);
gsl_vector_view Li = gsl_matrix_column(&L0.matrix,i);
gsl_vector_view Lj = gsl_matrix_column(&L0.matrix,j);
gsl_blas_drot(&Li.vector, &Lj.vector, c, -s);
}
#else
for (k = GSL_MIN (i, j); k < N; k++)
{
double lki = gsl_matrix_get (L, k, i);
double lkj = gsl_matrix_get (L, k, j);
gsl_matrix_set (L, k, i, c * lki - s * lkj);
gsl_matrix_set (L, k, j, s * lki + c * lkj);
}
#endif
}
inline static void
apply_givens_qr (size_t M, size_t N, gsl_matrix * Q, gsl_matrix * R,
size_t i, size_t j, double c, double s)
{
size_t k;
/* Apply rotation to matrix Q, Q' = Q G */
#if USE_BLAS
{
gsl_matrix_view Q0M = gsl_matrix_submatrix(Q,0,0,M,j+1);
gsl_vector_view Qi = gsl_matrix_column(&Q0M.matrix,i);
gsl_vector_view Qj = gsl_matrix_column(&Q0M.matrix,j);
gsl_blas_drot(&Qi.vector, &Qj.vector, c, -s);
}
#else
for (k = 0; k < M; k++)
{
double qki = gsl_matrix_get (Q, k, i);
double qkj = gsl_matrix_get (Q, k, j);
gsl_matrix_set (Q, k, i, qki * c - qkj * s);
gsl_matrix_set (Q, k, j, qki * s + qkj * c);
}
#endif
/* Apply rotation to matrix R, R' = G^T R (note: upper triangular so
zero for column < row) */
#if USE_BLAS
{
k = GSL_MIN(i,j);
gsl_matrix_view R0 = gsl_matrix_submatrix(R, 0, k, j+1, N-k);
gsl_vector_view Ri = gsl_matrix_row(&R0.matrix,i);
gsl_vector_view Rj = gsl_matrix_row(&R0.matrix,j);
gsl_blas_drot(&Ri.vector, &Rj.vector, c, -s);
}
#else
for (k = GSL_MIN (i, j); k < N; k++)
{
double rik = gsl_matrix_get (R, i, k);
double rjk = gsl_matrix_get (R, j, k);
gsl_matrix_set (R, i, k, c * rik - s * rjk);
gsl_matrix_set (R, j, k, s * rik + c * rjk);
}
#endif
}
int
gsl_multifit_linear_applyW(const gsl_matrix * X,
const gsl_vector * w,
const gsl_vector * y,
gsl_matrix * WX,
gsl_vector * Wy)
{
const size_t n = X->size1;
const size_t p = X->size2;
if (n != y->size)
{
GSL_ERROR("y vector does not match X", GSL_EBADLEN);
}
else if (w != NULL && n != w->size)
{
GSL_ERROR("weight vector does not match X", GSL_EBADLEN);
}
else if (n != WX->size1 || p != WX->size2)
{
GSL_ERROR("WX matrix dimensions do not match X", GSL_EBADLEN);
}
else if (n != Wy->size)
{
GSL_ERROR("Wy vector must be length n", GSL_EBADLEN);
}
else
{
size_t i;
/* copy WX = X; Wy = y if distinct pointers */
if (WX != X)
gsl_matrix_memcpy(WX, X);
if (Wy != y)
gsl_vector_memcpy(Wy, y);
if (w != NULL)
{
/* construct WX = sqrt(W) X and Wy = sqrt(W) y */
for (i = 0; i < n; ++i)
{
double wi = gsl_vector_get(w, i);
double swi;
gsl_vector_view row = gsl_matrix_row(WX, i);
double *yi = gsl_vector_ptr(Wy, i);
if (wi < 0.0)
wi = 0.0;
swi = sqrt(wi);
gsl_vector_scale(&row.vector, swi);
*yi *= swi;
}
}
return GSL_SUCCESS;
}
}
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;
unsigned int nRows = tm->nRows, nParam = tm->nParam;
gsl_matrix *tXX = gsl_matrix_alloc(nParam, nParam);
while (isValid == TRUE) {
// if all isSingular==TRUE
for (j = 0; j < nRows; j++) {
// resample Y, X, offsets accordingly
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);
}
}
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);
}
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;
}
for (k = 2; k < nParam + 2; k++) {
subX2(GrpXs[0].matrix, k - 2, GrpXs[k].matrix);
}
gsl_matrix_free(tXX);
return SUCCESS;
}
void pca_whiten(
gsl_matrix *input,// NOBS x NVOX
size_t const NCOMP, //
gsl_matrix *x_white, // NCOMP x NVOX
gsl_matrix *white, // NCOMP x NSUB
gsl_matrix *dewhite, //NSUB x NCOMP
int demean){
// get input reference
size_t NSUB = input->size1;
// demean input matrix
if (demean){
matrix_demean(input);
}
// Convariance Matrix
gsl_matrix *cov = gsl_matrix_alloc(NSUB, NSUB);
matrix_cov(input, cov);
// Set up eigen decomposition
gsl_vector *eval = gsl_vector_alloc(NCOMP); //eigen values
gsl_matrix *evec = gsl_matrix_alloc(NSUB, NCOMP);
rr_eig(cov, eval, evec, NCOMP );
//Computing whitening matrix
gsl_matrix_transpose_memcpy(white, evec);
gsl_vector_view v;
double e;
size_t i;
// white = eval^{-1/2} evec^T
#pragma omp parallel for private(i,e,v)
for (i = 0; i < NCOMP; i++) {
e = gsl_vector_get(eval,i);
v = gsl_matrix_row(white,i);
gsl_blas_dscal(1/sqrt(e), &v.vector);
}
// Computing dewhitening matrix
gsl_matrix_memcpy(dewhite, evec);
// dewhite = evec eval^{1/2}
#pragma omp parallel for private(i,e,v)
for (i = 0; i < NCOMP; i++) {
e = gsl_vector_get(eval,i);
v = gsl_matrix_column(dewhite,i);
gsl_blas_dscal(sqrt(e), &v.vector);
}
// whitening data (white x Input)
gsl_blas_dgemm(CblasNoTrans,CblasNoTrans,1.0,
white, input, 0.0, x_white);
gsl_matrix_free(cov);
gsl_matrix_free(evec);
gsl_vector_free(eval);
}
int
gsl_linalg_cholesky_invert(gsl_matrix * LLT)
{
if (LLT->size1 != LLT->size2)
{
GSL_ERROR ("cholesky matrix must be square", GSL_ENOTSQR);
}
else
{
const size_t N = LLT->size1;
size_t i;
gsl_vector_view v1, v2;
/* invert the lower triangle of LLT */
gsl_linalg_tri_lower_invert(LLT);
/*
* The lower triangle of LLT now contains L^{-1}. Now compute
* A^{-1} = L^{-T} L^{-1}
*/
for (i = 0; i < N; ++i)
{
double aii = gsl_matrix_get(LLT, i, i);
if (i < N - 1)
{
double tmp;
v1 = gsl_matrix_subcolumn(LLT, i, i, N - i);
gsl_blas_ddot(&v1.vector, &v1.vector, &tmp);
gsl_matrix_set(LLT, i, i, tmp);
if (i > 0)
{
gsl_matrix_view m = gsl_matrix_submatrix(LLT, i + 1, 0, N - i - 1, i);
v1 = gsl_matrix_subcolumn(LLT, i, i + 1, N - i - 1);
v2 = gsl_matrix_subrow(LLT, i, 0, i);
gsl_blas_dgemv(CblasTrans, 1.0, &m.matrix, &v1.vector, aii, &v2.vector);
}
}
else
{
v1 = gsl_matrix_row(LLT, N - 1);
gsl_blas_dscal(aii, &v1.vector);
}
}
/* copy lower triangle to upper */
gsl_matrix_transpose_tricpy('L', 0, LLT, LLT);
return GSL_SUCCESS;
}
} /* gsl_linalg_cholesky_invert() */
// initial calculation of function values at all vertices
void simplex_initialize(double f(gsl_vector* x), simplex_workspace* W)
{
int i, m= W->n+1;
gsl_vector_view v;
for(i=0; i < m; i++)
{
v = gsl_matrix_row(W->simplex,i);
gsl_vector_set(W->fp,i,f(&v.vector));
}
}
int
lls_fold(gsl_matrix *A, gsl_vector *b,
gsl_vector *wts, lls_workspace *w)
{
const size_t n = A->size1;
if (A->size2 != w->p)
{
GSL_ERROR("A has wrong size2", GSL_EBADLEN);
}
else if (n != b->size)
{
GSL_ERROR("b has wrong size", GSL_EBADLEN);
}
else if (n != wts->size)
{
GSL_ERROR("wts has wrong size", GSL_EBADLEN);
}
else
{
int s = 0;
size_t i;
double bnorm;
for (i = 0; i < n; ++i)
{
gsl_vector_view rv = gsl_matrix_row(A, i);
double *bi = gsl_vector_ptr(b, i);
double wi = gsl_vector_get(wts, i);
double swi = sqrt(wi);
/* A <- sqrt(W) A */
gsl_vector_scale(&rv.vector, swi);
/* b <- sqrt(W) b */
*bi *= swi;
}
/* ATA += A^T W A, using only the upper half of the matrix */
s = gsl_blas_dsyrk(CblasUpper, CblasTrans, 1.0, A, 1.0, w->ATA);
if (s)
return s;
/* ATb += A^T W b */
s = gsl_blas_dgemv(CblasTrans, 1.0, A, b, 1.0, w->ATb);
if (s)
return s;
/* bTb += b^T W b */
bnorm = gsl_blas_dnrm2(b);
w->bTb += bnorm * bnorm;
return s;
}
} /* lls_fold() */
