/**
* 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;
}
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;
}
void inference(char* dataset, char* model_root, char* out)
{
int i;
char fname[100];
// read the data and model
corpus * corpus = read_data(dataset);
llna_model * model = read_llna_model(model_root);
gsl_vector * lhood = gsl_vector_alloc(corpus->ndocs);
gsl_matrix * corpus_nu = gsl_matrix_alloc(corpus->ndocs, model->k);
gsl_matrix * corpus_lambda = gsl_matrix_alloc(corpus->ndocs, model->k);
// gsl_matrix * topic_lhoods = gsl_matrix_alloc(corpus->ndocs, model->k);
gsl_matrix * phi_sums = gsl_matrix_alloc(corpus->ndocs, model->k);
// approximate inference
init_temp_vectors(model->k-1); // !!! hacky
sprintf(fname, "%s-word-assgn.dat", out);
FILE* word_assignment_file = fopen(fname, "w");
for (i = 0; i < corpus->ndocs; i++)
{
doc doc = corpus->docs[i];
llna_var_param * var = new_llna_var_param(doc.nterms, model->k);
init_var_unif(var, &doc, model);
vset(lhood, i, var_inference(var, &doc, model));
gsl_matrix_set_row(corpus_lambda, i, var->lambda);
gsl_matrix_set_row(corpus_nu, i, var->nu);
gsl_vector curr_row = gsl_matrix_row(phi_sums, i).vector;
col_sum(var->phi, &curr_row);
write_word_assignment(word_assignment_file, &doc, var->phi);
printf("document %05d, niter = %05d\n", i, var->niter);
free_llna_var_param(var);
}
// output likelihood and some variational parameters
sprintf(fname, "%s-ctm-lhood.dat", out);
printf_vector(fname, lhood);
sprintf(fname, "%s-lambda.dat", out);
printf_matrix(fname, corpus_lambda);
sprintf(fname, "%s-nu.dat", out);
printf_matrix(fname, corpus_nu);
sprintf(fname, "%s-phi-sum.dat", out);
printf_matrix(fname, phi_sums);
}
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;
}
static int
nmsimplex_set (void *vstate, gsl_multimin_function * f,
const gsl_vector * x,
double *size, const gsl_vector * step_size)
{
int status;
size_t i;
double val;
nmsimplex_state_t *state = (nmsimplex_state_t *) vstate;
gsl_vector *xtemp = state->ws1;
/* first point is the original x0 */
val = GSL_MULTIMIN_FN_EVAL (f, x);
gsl_matrix_set_row (state->x1, 0, x);
gsl_vector_set (state->y1, 0, val);
/* following points are initialized to x0 + step_size */
for (i = 0; i < x->size; i++)
{
status = gsl_vector_memcpy (xtemp, x);
if (status != 0)
{
GSL_ERROR ("vector memcopy failed", GSL_EFAILED);
}
val = gsl_vector_get (xtemp, i) + gsl_vector_get (step_size, i);
gsl_vector_set (xtemp, i, val);
val = GSL_MULTIMIN_FN_EVAL (f, xtemp);
gsl_matrix_set_row (state->x1, i + 1, xtemp);
gsl_vector_set (state->y1, i + 1, val);
}
/* Initialize simplex size */
*size = nmsimplex_size (state);
return GSL_SUCCESS;
}
apop_data * apop_bootstrap_cov_base(apop_data * data, apop_model *model, gsl_rng *rng, int iterations, char keep_boots, char ignore_nans, apop_data **boot_store){
#endif
Get_vmsizes(data); //vsize, msize1, msize2
apop_model *e = apop_model_copy(model);
apop_data *subset = apop_data_copy(data);
apop_data *array_of_boots = NULL,
*summary;
//prevent and infinite regression of covariance calculation.
Apop_model_add_group(e, apop_parts_wanted); //default wants for nothing.
size_t i, nan_draws=0;
apop_name *tmpnames = (data && data->names) ? data->names : NULL; //save on some copying below.
if (data && data->names) data->names = NULL;
int height = GSL_MAX(msize1, GSL_MAX(vsize, (data?(*data->textsize):0)));
for (i=0; i<iterations && nan_draws < iterations; i++){
for (size_t j=0; j< height; j++){ //create the data set
size_t randrow = gsl_rng_uniform_int(rng, height);
apop_data_memcpy(Apop_r(subset, j), Apop_r(data, randrow));
}
//get the parameter estimates.
apop_model *est = apop_estimate(subset, e);
gsl_vector *estp = apop_data_pack(est->parameters);
if (!gsl_isnan(apop_sum(estp))){
if (i==0){
array_of_boots = apop_data_alloc(iterations, estp->size);
apop_name_stack(array_of_boots->names, est->parameters->names, 'c', 'v');
apop_name_stack(array_of_boots->names, est->parameters->names, 'c', 'c');
apop_name_stack(array_of_boots->names, est->parameters->names, 'c', 'r');
}
gsl_matrix_set_row(array_of_boots->matrix, i, estp);
} else if (ignore_nans=='y'){
i--;
nan_draws++;
}
apop_model_free(est);
gsl_vector_free(estp);
}
if(data) data->names = tmpnames;
apop_data_free(subset);
apop_model_free(e);
int set_error=0;
Apop_stopif(i == 0 && nan_draws == iterations, apop_return_data_error(N),
1, "I ran into %i NaNs and no not-NaN estimations, and so stopped. "
, iterations);
Apop_stopif(nan_draws == iterations, set_error++;
apop_matrix_realloc(array_of_boots->matrix, i, array_of_boots->matrix->size2),
1, "I ran into %i NaNs, and so stopped. Returning results based "
"on %zu bootstrap iterations.", iterations, i);
summary = apop_data_covariance(array_of_boots);
if (boot_store) *boot_store = array_of_boots;
else apop_data_free(array_of_boots);
if (set_error) summary->error = 'N';
return summary;
}
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;
while (isValid == TRUE) {
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);
}
// 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);
// 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_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;
}
gsl_matrix_free(tXX);
return SUCCESS;
}
void Compute_NeighborMatrix(gsl_matrix * Neighbors)
{
// RESET THE NEIGHBORING MATRIX
gsl_matrix_set_zero(Neighbors);
// TODO: May we obtain a speedup using vector_view instead
// of matrix_set_row?
gsl_vector * neighborVector = gsl_vector_calloc (27);
for (int cell=0;cell<Mx*My*Mz;cell++)
{
Compute_NeighborCells(cell, neighborVector);
gsl_matrix_set_row(Neighbors, cell, neighborVector);
}
gsl_vector_free(neighborVector);
}
void predict_proj_lambda(double* x, LEARN_A_MODEL model,void (*J_func)(const double*,const int,double*),double* centres,double variance,double* Iu, double*A){
gsl_matrix* Rn = gsl_matrix_alloc(model.dim_r,model.dim_r);
memcpy(Rn->data,Iu,model.dim_r*model.dim_r*sizeof(double));
gsl_matrix* lambda = gsl_matrix_alloc(model.dim_k,model.dim_r);
gsl_matrix_set_all(lambda,0);
int k;
double * BX, *W_BX,*W_BX_T,*theta,*alpha,*J_x;
BX = malloc(model.dim_b*1*sizeof(double));
theta = malloc(1*model.dim_t*sizeof(double));
alpha = malloc(1*model.dim_r*sizeof(double));
gsl_vector* lambda_vec = gsl_vector_alloc(model.dim_r);
for (k=1;k<model.dim_k+1;k++){
W_BX = malloc((model.dim_u-k)*1*sizeof(double));
W_BX_T = malloc(1*(model.dim_u-k)*sizeof(double));
ccl_gaussian_rbf(x,model.dim_x,1,centres,model.dim_x,model.dim_b,variance,BX);
ccl_dot_product(model.w[k-1],model.dim_u-k,model.dim_b,BX,model.dim_b,1,W_BX);
ccl_mat_transpose(W_BX,model.dim_u-k,1,W_BX_T);
free(W_BX);
if (k ==1){
memcpy(theta,W_BX_T,1*(model.dim_u-k)*sizeof(double));
free(W_BX_T);
}
else{
gsl_matrix* ones = gsl_matrix_alloc(1,k);
gsl_matrix_set_all(ones,1);
gsl_matrix_scale(ones,M_PI/2);
mat_hotz_app(ones->data,1,k,W_BX_T,model.dim_n,model.dim_u-k,theta);
free(W_BX_T);
gsl_matrix_free(ones);
}
ccl_get_unit_vector_from_matrix(theta,1,model.dim_t,alpha);
ccl_dot_product(alpha,k,model.dim_r,Rn->data,model.dim_r,model.dim_r,lambda_vec->data);
gsl_matrix_set_row(lambda,k-1,lambda_vec);
ccl_get_rotation_matrix(theta,Rn->data,&model,k-1,Rn->data);
}
memcpy(A,lambda->data,model.dim_k*model.dim_r*sizeof(double));
J_x = malloc(model.dim_r*model.dim_x*sizeof(double));
// J_func(x,model.dim_x,J_x);
// print_mat_d(alpha,1,model.dim_r);
// ccl_dot_product(lambda->data,model.dim_k,model.dim_r,J_x,model.dim_r,model.dim_x,A);
free(BX);
free(theta);
free(alpha);
free(J_x);
gsl_vector_free(lambda_vec);
gsl_matrix_free(lambda);
gsl_matrix_free(Rn);
}
// produce matrix with one row missing, for each possible row
// Do some math on the new sub-matrix
// Ben Klemens - MWD 4.6
static gsl_vector *jack_iteration(gsl_matrix *m, math_fn do_math){
int height = m->size1;
gsl_vector *out = gsl_vector_alloc(height);
apop_data *reduced = apop_data_alloc(0, (size_t)height - 1, (int)m->size2);
Apop_submatrix(m, 1, 0, height - 1, m->size2, mv);
gsl_matrix_memcpy(reduced->matrix, mv);
for (int i=0; i< height; i++){
if (i % 100 == 0)
std::cerr << "...jacknife at " << SeqLib::AddCommas(i) << " of " << SeqLib::AddCommas(height) << std::endl;
gsl_vector_set(out, i, do_math(reduced)); // returns scalar output of do_math
if (i < height - 1){ // create a new submatrix with new row ommited
Apop_matrix_row(m, i, onerow);
gsl_matrix_set_row(reduced->matrix, i, onerow);
}
}
return out;
}
int stack_matrix_array(gsl_matrix ** pieces, size_t N,gsl_matrix * m_assembled) {
/* First pieces fix the width */
size_t width = pieces[0]->size2;
gsl_vector * v_T = gsl_vector_calloc(width);
size_t i;
size_t offset = 0;
for(i = 0; i < N; i++) {
size_t j;
size_t height = pieces[i]->size1;
for(j = 0; j < height; j++) {
gsl_matrix_get_row(v_T,pieces[i],j); /* Take a slice */
gsl_matrix_set_row(m_assembled,offset+j,v_T);
}
offset += height;
}
gsl_vector_free(v_T);
}
/** Give me a data set and a model, and I'll give you the jackknifed covariance matrix of the model parameters.
The basic algorithm for the jackknife (glossing over the details): create a sequence of data
sets, each with exactly one observation removed, and then produce a new set of parameter estimates
using that slightly shortened data set. Then, find the covariance matrix of the derived parameters.
\li Jackknife or bootstrap? As a broad rule of thumb, the jackknife works best on models
that are closer to linear. The worse a linear approximation does (at the given data),
the worse the jackknife approximates the variance.
\param in The data set. An \ref apop_data set where each row is a single data point.
\param model An \ref apop_model, that will be used internally by \ref apop_estimate.
\exception out->error=='n' \c NULL input data.
\return An \c apop_data set whose matrix element is the estimated covariance matrix of the parameters.
\see apop_bootstrap_cov
For example:
\include jack.c
*/
apop_data * apop_jackknife_cov(apop_data *in, apop_model *model){
Apop_stopif(!in, apop_return_data_error(n), 0, "The data input can't be NULL.");
Get_vmsizes(in); //msize1, msize2, vsize
apop_model *e = apop_model_copy(model);
int i, n = GSL_MAX(msize1, GSL_MAX(vsize, in->textsize[0]));
apop_model *overall_est = e->parameters ? e : apop_estimate(in, e);//if not estimated, do so
gsl_vector *overall_params = apop_data_pack(overall_est->parameters);
gsl_vector_scale(overall_params, n); //do it just once.
gsl_vector *pseudoval = gsl_vector_alloc(overall_params->size);
//Copy the original, minus the first row.
apop_data *subset = apop_data_copy(Apop_rs(in, 1, n-1));
apop_name *tmpnames = in->names;
in->names = NULL; //save on some copying below.
apop_data *array_of_boots = apop_data_alloc(n, overall_params->size);
for(i = -1; i< n-1; i++){
//Get a view of row i, and copy it to position i-1 in the short matrix.
if (i >= 0) apop_data_memcpy(Apop_r(subset, i), Apop_r(in, i));
apop_model *est = apop_estimate(subset, e);
gsl_vector *estp = apop_data_pack(est->parameters);
gsl_vector_memcpy(pseudoval, overall_params);// *n above.
gsl_vector_scale(estp, n-1);
gsl_vector_sub(pseudoval, estp);
gsl_matrix_set_row(array_of_boots->matrix, i+1, pseudoval);
apop_model_free(est);
gsl_vector_free(estp);
}
in->names = tmpnames;
apop_data *out = apop_data_covariance(array_of_boots);
gsl_matrix_scale(out->matrix, 1./(n-1.));
apop_data_free(subset);
gsl_vector_free(pseudoval);
apop_data_free(array_of_boots);
if (e!=overall_est)
apop_model_free(overall_est);
apop_model_free(e);
gsl_vector_free(overall_params);
return out;
}
/**
* Integrate the 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 *
model::integrateForward(const double length, const double spinup,
const size_t sampling)
{
size_t nt = (size_t) (length / scheme->getTimeStep() + 0.1);
size_t ntSpinup = (size_t) (spinup / scheme->getTimeStep() + 0.1);
gsl_matrix *data = gsl_matrix_alloc((size_t) ((nt - ntSpinup) / sampling),
dim);
// Get spinup
for (size_t i = 1; i <= ntSpinup; i++)
stepForward();
// Get record
for (size_t i = ntSpinup+1; i <= nt; i++)
{
stepForward();
// Save state
if (i%sampling == 0)
gsl_matrix_set_row(data, (i - ntSpinup) / sampling - 1, currentState);
}
return data;
}
int GlmTest::anova(glm *fit, gsl_matrix *isXvarIn) {
// Assume the models have been already sorted (in R)
Xin = isXvarIn;
nModels = Xin->size1;
double *rdf = new double[nModels];
unsigned int nP, i, j, k;
unsigned int ID0, ID1, nP0, nP1;
unsigned int nRows = tm->nRows, nVars = tm->nVars, nParam = tm->nParam;
unsigned int mtype = fit->mmRef->model - 1;
dfDiff = new unsigned int[nModels - 1];
anovaStat = gsl_matrix_alloc((nModels - 1), nVars + 1);
Panova = gsl_matrix_alloc((nModels - 1), nVars + 1);
gsl_vector *bStat = gsl_vector_alloc(nVars + 1);
bootStore = gsl_matrix_alloc(tm->nboot, nVars + 1);
gsl_matrix_set_zero(anovaStat);
gsl_matrix_set_zero(Panova);
gsl_vector_set_zero(bStat);
// There has to be a better way to do this
PoissonGlm pNull(fit->mmRef), pAlt(fit->mmRef);
BinGlm binNull(fit->mmRef), binAlt(fit->mmRef);
NBinGlm nbNull(fit->mmRef), nbAlt(fit->mmRef);
GammaGlm gammaNull(fit->mmRef), gammaAlt(fit->mmRef);
PoissonGlm pNullb(fit->mmRef), pAltb(fit->mmRef);
BinGlm binNullb(fit->mmRef), binAltb(fit->mmRef);
NBinGlm nbNullb(fit->mmRef), nbAltb(fit->mmRef);
GammaGlm gammaNullb(fit->mmRef), gammaAltb(fit->mmRef);
glm *PtrNull[4] = {&pNull, &nbNull, &binNull, &gammaNull};
glm *PtrAlt[4] = {&pAlt, &nbAlt, &binAlt, &gammaAlt};
glm *bNull[4] = {&pNullb, &nbNullb, &binNullb, &gammaNullb};
glm *bAlt[4] = {&pAltb, &nbAltb, &binAltb, &gammaAltb};
double *suj, *buj, *puj;
gsl_vector_view teststat, unitstat, ref1, ref0;
gsl_matrix *X0 = NULL, *X1 = NULL, *L1 = NULL, *tmp1 = NULL, *BetaO = NULL;
gsl_matrix *bO = NULL, *bY = gsl_matrix_alloc(nRows, nVars);
bO = gsl_matrix_alloc(nRows, nVars);
gsl_permutation *sortid = NULL;
if (tm->punit == FREESTEP)
sortid = gsl_permutation_alloc(nVars);
// ======= Fit the (first) Alt model =========//
for (i = 0; i < nModels; i++) {
nP = 0;
for (k = 0; k < nParam; k++)
if (gsl_matrix_get(Xin, i, k) != FALSE)
nP++;
rdf[i] = nRows - nP;
}
for (i = 1; i < nModels; i++) {
// ======= Fit the Null model =========//
ID0 = i;
ID1 = i - 1;
nP0 = nRows - (unsigned int)rdf[ID0];
nP1 = nRows - (unsigned int)rdf[ID1];
// Degrees of freedom
dfDiff[i - 1] = nP1 - nP0;
ref1 = gsl_matrix_row(Xin, ID1);
ref0 = gsl_matrix_row(Xin, ID0);
X0 = gsl_matrix_alloc(nRows, nP0);
subX(fit->Xref, &ref0.vector, X0);
X1 = gsl_matrix_alloc(nRows, nP1);
subX(fit->Xref, &ref1.vector, X1);
// ======= Get multivariate test statistics =======//
// Estimate shrinkage parametr only once under H1
// See "FW: Doubts R package "mvabund" (12/14/11)
teststat = gsl_matrix_row(anovaStat, (i - 1));
PtrNull[mtype]->regression(fit->Yref, X0, fit->Oref, NULL);
if (tm->test == SCORE) {
lambda = gsl_vector_get(tm->anova_lambda, ID0);
GetR(PtrNull[mtype]->Res, tm->corr, lambda, Rlambda);
GeeScore(X1, PtrNull[mtype], &teststat.vector);
} else if (tm->test == WALD) {
PtrAlt[mtype]->regression(fit->Yref, X1, fit->Oref, NULL);
L1 = gsl_matrix_alloc(nP1 - nP0, nP1);
tmp1 = gsl_matrix_alloc(nParam, nP1);
subX(L, &ref1.vector, tmp1);
subXrow1(tmp1, &ref0.vector, &ref1.vector, L1);
lambda = gsl_vector_get(tm->anova_lambda, ID1);
GetR(PtrAlt[mtype]->Res, tm->corr, lambda, Rlambda);
GeeWald(PtrAlt[mtype], L1, &teststat.vector);
} else { // test is LR
BetaO = gsl_matrix_alloc(nP1, nVars);
addXrow2(PtrNull[mtype]->Beta, &ref1.vector, BetaO);
PtrAlt[mtype]->regression(fit->Yref, X1, fit->Oref, BetaO);
GeeLR(PtrAlt[mtype], PtrNull[mtype], &teststat.vector);
}
if (tm->resamp == MONTECARLO) {
lambda = gsl_vector_get(tm->anova_lambda, ID0);
GetR(fit->Res, tm->corr, lambda, Sigma);
setMonteCarlo(PtrNull[mtype], XBeta, Sigma);
}
// ======= Get univariate test statistics =======//
if (tm->punit == FREESTEP) {
unitstat = gsl_vector_subvector(&teststat.vector, 1, nVars);
gsl_sort_vector_index(sortid, &unitstat.vector);
gsl_permutation_reverse(sortid);
}
// ======= Get resampling distribution under H0 ===== //
nSamp = 0;
double dif, timelast = 0;
clock_t clk_start = clock();
if (tm->showtime == TRUE)
printf("Resampling begins for test %d.\n", i);
for (j = 0; j < tm->nboot; j++) {
// printf("simu %d :", j);
nSamp++;
gsl_vector_set_zero(bStat);
if (tm->resamp == CASEBOOT) {
resampAnovaCase(PtrAlt[mtype], bY, X1, bO, j);
subX(X1, &ref0.vector, X0);
} else {
resampNonCase(PtrNull[mtype], bY, j);
gsl_matrix_memcpy(bO, fit->Oref);
}
if (tm->test == WALD) {
bAlt[mtype]->regression(bY, X1, bO, NULL);
lambda = gsl_vector_get(tm->anova_lambda, ID1);
GetR(bAlt[mtype]->Res, tm->corr, lambda, Rlambda);
GeeWald(bAlt[mtype], L1, bStat);
} else if (tm->test == SCORE) {
bNull[mtype]->regression(bY, X0, bO, NULL);
lambda = gsl_vector_get(tm->anova_lambda, ID0);
GetR(bNull[mtype]->Res, tm->corr, lambda, Rlambda);
GeeScore(X1, bNull[mtype], bStat);
} else {
bNull[mtype]->regression(bY, X0, bO, NULL);
addXrow2(bNull[mtype]->Beta, &ref1.vector, BetaO);
bAlt[mtype]->regression(bY, X1, bO, BetaO);
GeeLR(bAlt[mtype], bNull[mtype], bStat);
}
gsl_matrix_set_row(bootStore, j, bStat);
// ----- get multivariate counts ------- //
buj = gsl_vector_ptr(bStat, 0);
suj = gsl_matrix_ptr(anovaStat, i - 1, 0);
puj = gsl_matrix_ptr(Panova, i - 1, 0);
if (*(buj) > (*(suj)-1e-8))
*puj = *puj + 1;
// ------ get univariate counts ---------//
calcAdjustP(tm->punit, nVars, buj + 1, suj + 1, puj + 1, sortid);
// Prompts
if ((tm->showtime == TRUE) & (j % 100 == 0)) {
dif = (float)(clock() - clk_start) / (float)CLOCKS_PER_SEC;
timelast += (double)dif / 60;
printf("\tResampling run %d finished. Time elapsed: %.2f minutes...\n",
j, timelast);
clk_start = clock();
}
} // end j for loop
// ========= get p-values ======== //
if (tm->punit == FREESTEP) {
puj = gsl_matrix_ptr(Panova, i - 1, 1);
reinforceP(puj, nVars, sortid);
}
// } // end for i loop
if (BetaO != NULL)
gsl_matrix_free(BetaO);
if (X0 != NULL)
gsl_matrix_free(X0);
if (X1 != NULL)
gsl_matrix_free(X1);
if (tm->test == WALD) {
if (L1 != NULL)
gsl_matrix_free(L1);
if (tmp1 != NULL)
gsl_matrix_free(tmp1);
}
} // end i for loop and test for loop
// p = (#exceeding observed stat + 1)/(#nboot+1)
gsl_matrix_add_constant(Panova, 1.0);
gsl_matrix_scale(Panova, (double)1 / (nSamp + 1.0));
bAlt[mtype]->releaseGlm();
PtrAlt[mtype]->releaseGlm();
if (tm->test != WALD) {
bNull[mtype]->releaseGlm();
PtrNull[mtype]->releaseGlm();
}
delete[] rdf;
if (sortid != NULL)
gsl_permutation_free(sortid);
gsl_vector_free(bStat);
gsl_matrix_free(bY);
if (bO != NULL)
gsl_matrix_free(bO);
return SUCCESS;
}
static int
nmsimplex_iterate (void *vstate, gsl_multimin_function * f,
gsl_vector * x, double *size, double *fval)
{
/* Simplex iteration tries to minimize function f value */
/* Includes corrections from Ivo Alxneit <*****@*****.**> */
nmsimplex_state_t *state = (nmsimplex_state_t *) vstate;
/* xc and xc2 vectors store tried corner point coordinates */
gsl_vector *xc = state->ws1;
gsl_vector *xc2 = state->ws2;
gsl_vector *y1 = state->y1;
gsl_matrix *x1 = state->x1;
size_t n = y1->size;
size_t i;
size_t hi = 0, s_hi = 0, lo = 0;
double dhi, ds_hi, dlo;
int status;
double val, val2;
/* get index of highest, second highest and lowest point */
dhi = ds_hi = dlo = gsl_vector_get (y1, 0);
for (i = 1; i < n; i++)
{
val = (gsl_vector_get (y1, i));
if (val < dlo)
{
dlo = val;
lo = i;
}
else if (val > dhi)
{
ds_hi = dhi;
s_hi = hi;
dhi = val;
hi = i;
}
else if (val > ds_hi)
{
ds_hi = val;
s_hi = i;
}
}
/* reflect the highest value */
val = nmsimplex_move_corner (-1.0, state, hi, xc, f);
if (val < gsl_vector_get (y1, lo))
{
/* reflected point becomes lowest point, try expansion */
val2 = nmsimplex_move_corner (-2.0, state, hi, xc2, f);
if (val2 < gsl_vector_get (y1, lo))
{
gsl_matrix_set_row (x1, hi, xc2);
gsl_vector_set (y1, hi, val2);
}
else
{
gsl_matrix_set_row (x1, hi, xc);
gsl_vector_set (y1, hi, val);
}
}
/* reflection does not improve things enough */
else if (val > gsl_vector_get (y1, s_hi))
{
if (val <= gsl_vector_get (y1, hi))
{
/* if trial point is better than highest point, replace
highest point */
gsl_matrix_set_row (x1, hi, xc);
gsl_vector_set (y1, hi, val);
}
/* try one dimensional contraction */
val2 = nmsimplex_move_corner (0.5, state, hi, xc2, f);
if (val2 <= gsl_vector_get (y1, hi))
{
gsl_matrix_set_row (state->x1, hi, xc2);
gsl_vector_set (y1, hi, val2);
}
else
{
/* contract the whole simplex in respect to the best point */
status = nmsimplex_contract_by_best (state, lo, xc, f);
if (status != 0)
{
GSL_ERROR ("nmsimplex_contract_by_best failed", GSL_EFAILED);
}
}
}
else
{
/* trial point is better than second highest point.
Replace highest point by it */
gsl_matrix_set_row (x1, hi, xc);
gsl_vector_set (y1, hi, val);
}
/* return lowest point of simplex as x */
lo = gsl_vector_min_index (y1);
gsl_matrix_get_row (x, x1, lo);
*fval = gsl_vector_get (y1, lo);
/* Update simplex size */
*size = nmsimplex_size (state);
return GSL_SUCCESS;
}
main (int argc,char *argv[])
{
int ia,ib,ic,id,it,inow,ineigh,icont;
int in,ia2,ia3,irun,icurrent,ORTOGONALFLAG;
int RP, P,L,N,NRUNS,next,sweep,SHOWFLAG;
double u,field1,field2,field0,q,aux1,aux2;
double alfa,aux,Q1,Q2,QZ,RZQ,rho,R;
double pm,D,wmax,mQ,wx,wy,h_sigma,h_mean;
double TOL,MINLOGF,E;
double DELTA;
double E_new,Ex,DeltaE,ER;
double EW,meanhist,hvalue,wE,aratio;
double logG_old,logG_new,lf;
size_t i_old,i_new;
long seed;
double lGvR,lGv,DlG;
size_t iL,iR,i1,i2;
int I_endpoint[NBINS];
double lower,upper;
size_t i0;
FILE * wlsrange;
FILE * dos;
FILE * thermodynamics;
FILE * canonical;
FILE * logfile;
//FILE * pajek;
//***********************************
// Help
//***********************************
if (argc<15){
help();
return(1);
}
else{
DELTA = atof(argv[1]);
P = atoi(argv[2]);
RP = atoi(argv[3]);
L = atoi(argv[4]);
N = atoi(argv[5]);
TOL = atof(argv[6]);
MINLOGF = atof(argv[7]);
}
wlsrange=fopen(argv[8],"w");
dos=fopen(argv[9],"w");
thermodynamics=fopen(argv[10],"w");
canonical=fopen(argv[11],"w");
logfile=fopen(argv[12],"w");
SHOWFLAG = atoi(argv[13]);
ORTOGONALFLAG = atoi(argv[14]);
if ((ORTOGONALFLAG==1) && (P>L)) P=L;
//maximum number of orthogonal issues
if (SHOWFLAG==1){
printf("# parameters are DELTA=%1.2f P=%d ",DELTA,P);
printf("D=%d L=%d M=%d TOL=%1.2f MINLOGF=%g \n",L,N,RP,TOL,MINLOGF);
}
fprintf(logfile,"# parameters are DELTA=%1.2f P=%d D=%d",DELTA,P,L);
fprintf(logfile,"L=%d M=%d TOL=%1.2f MINLOGF=%g\n",L,RP,TOL,MINLOGF);
//**********************************************************************
// Alocate matrices
//**********************************************************************
gsl_matrix * sociedade = gsl_matrix_alloc(SIZE,L);
gsl_matrix * issue = gsl_matrix_alloc(P,L);
gsl_vector * current_issue = gsl_vector_alloc(L);
gsl_vector * v0 = gsl_vector_alloc(L);
gsl_vector * v1 = gsl_vector_alloc(L);
gsl_vector * Z = gsl_vector_alloc(L);
gsl_vector * E_borda = gsl_vector_alloc(NBINS);
//**********************************************************************
// Inicialization
//**********************************************************************
const gsl_rng_type * T;
gsl_rng * r;
gsl_rng_env_setup();
T = gsl_rng_default;
r=gsl_rng_alloc (T);
seed = time (NULL) * getpid();
//seed = 13188839657852;
gsl_rng_set(r,seed);
igraph_t graph;
igraph_vector_t neighbors;
igraph_vector_t result;
igraph_vector_t dim_vector;
igraph_real_t res;
igraph_bool_t C;
igraph_vector_init(&neighbors,1000);
igraph_vector_init(&result,0);
igraph_vector_init(&dim_vector,DIMENSION);
for(ic=0;ic<DIMENSION;ic++) VECTOR(dim_vector)[ic]=N;
gsl_histogram * HE = gsl_histogram_alloc (NBINS);
gsl_histogram * logG = gsl_histogram_alloc (NBINS);
gsl_histogram * LG = gsl_histogram_alloc (NBINS);
//********************************************************************
// Social Graph
//********************************************************************
//Barabasi-Alberts network
igraph_barabasi_game(&graph,SIZE,RP,&result,1,0);
/* for (inow=0;inow<SIZE;inow++){
igraph_neighbors(&graph,&neighbors,inow,IGRAPH_OUT);
printf("%d ",inow);
for(ic=0;ic<igraph_vector_size(&neighbors);ic++)
{
ineigh=(int)VECTOR(neighbors)[ic];
printf("%d ",ineigh);
}
printf("\n");
}*/
//pajek=fopen("graph.xml","w");
// igraph_write_graph_graphml(&graph,pajek);
//igraph_write_graph_pajek(&graph, pajek);
//fclose(pajek);
//**********************************************************************
//Quenched issues set and Zeitgeist
//**********************************************************************
gsl_vector_set_zero(Z);
gera_config(Z,issue,P,L,r,1.0);
if (ORTOGONALFLAG==1) gsl_matrix_set_identity(issue);
for (ib=0;ib<P;ib++)
{
gsl_matrix_get_row(current_issue,issue,ib);
gsl_blas_ddot(current_issue,current_issue,&Q1);
gsl_vector_scale(current_issue,1/sqrt(Q1));
gsl_vector_add(Z,current_issue);
}
gsl_blas_ddot(Z,Z,&QZ);
gsl_vector_scale(Z,1/sqrt(QZ));
//**********************************************************************
// Ground state energy
//**********************************************************************
double E0;
gera_config(Z,sociedade,SIZE,L,r,0);
E0 = hamiltoneana(sociedade,issue,SIZE,L,P,DELTA,graph);
double EMIN=E0;
double EMAX=-E0;
double E_old=E0;
gsl_histogram_set_ranges_uniform (HE,EMIN,EMAX);
gsl_histogram_set_ranges_uniform (logG,EMIN,EMAX);
if (SHOWFLAG==1) printf("# ground state: %3.0f\n",E0);
fprintf(logfile,"# ground state: %3.0f\n",E0);
//**********************************************************************
// Find sampling interval
//**********************************************************************
//printf("#finding the sampling interval...\n");
lf=1;
sweep=0;
icont=0;
int iflag=0;
int TMAX=NSWEEPS;
while(sweep<=TMAX){
if (icont==10000) {
//printf("%d sweeps\n",sweep);
icont=0;
}
for(it=0;it<SIZE;it++){
igraph_vector_init(&neighbors,SIZE);
//choose a random site
do{
inow=gsl_rng_uniform_int(r,SIZE);
}while((inow<0)||(inow>=SIZE));
gsl_matrix_get_row(v1,sociedade,inow);
igraph_neighbors(&graph,&neighbors,inow,IGRAPH_OUT);
//generates a random vector v1
gsl_vector_memcpy(v0,v1);
gera_vetor(v1,L,r);
//calculates energy change when v0->v1
// in site inow
DeltaE=variacaoE(v0,v1,inow,sociedade,
issue,N,L,P,DELTA,graph,neighbors);
E_new=E_old+DeltaE;
//WL: accepts in [EMIN,EMAX]
if ((E_new>EMIN) && (E_new<EMAX))
{
gsl_histogram_find(logG,E_old,&i_old);
logG_old=gsl_histogram_get(logG,i_old);
gsl_histogram_find(logG,E_new,&i_new);
logG_new=gsl_histogram_get(logG,i_new);
wE = GSL_MIN(exp(logG_old-logG_new),1);
if (gsl_rng_uniform(r)<wE){
E_old=E_new;
gsl_matrix_set_row(sociedade,inow,v1);
}
}
//WL: update histograms
gsl_histogram_increment(HE,E_old);
gsl_histogram_accumulate(logG,E_old,lf);
igraph_vector_destroy(&neighbors);
}
sweep++;
icont++;
}
gsl_histogram_fprintf(wlsrange,HE,"%g","%g");
double maxH=gsl_histogram_max_val(HE);
//printf("ok\n");
Ex=0;
hvalue=maxH;
while((hvalue>TOL*maxH)&&(Ex>EMIN)){
gsl_histogram_find(HE,Ex,&i0);
hvalue=gsl_histogram_get(HE,i0);
Ex-=1;
if(Ex<=EMAX)TMAX+=10000;
}
EMIN=Ex;
Ex=0;
hvalue=maxH;
while((hvalue>TOL*maxH)&&(Ex<EMAX)) {
gsl_histogram_find(HE,Ex,&i0);
hvalue=gsl_histogram_get(HE,i0);
Ex+=1;
if(Ex>=EMAX)TMAX+=10000;
}
EMAX=Ex;
EMAX=GSL_MIN(10.0,Ex);
if (SHOWFLAG==1)
printf("# the sampling interval is [%3.0f,%3.0f] found in %d sweeps \n\n"
,EMIN,EMAX,sweep);
fprintf(logfile,
"# the sampling interval is [%3.0f,%3.0f] found in %d sweeps \n\n"
,EMIN,EMAX,sweep);
gsl_histogram_set_ranges_uniform (HE,EMIN-1,EMAX+1);
gsl_histogram_set_ranges_uniform (logG,EMIN-1,EMAX+1);
gsl_histogram_set_ranges_uniform (LG,EMIN-1,EMAX+1);
//**********************************************************************
// WLS
//**********************************************************************
int iE,itera=0;
double endpoints[NBINS];
double w = WINDOW; //(EMAX-EMIN)/10.0;
//printf("W=%f\n",w);
lf=1;
//RESOLUTION ----> <------RESOLUTION*****
do{
int iverify=0,iborda=0,flat=0;
sweep=0;
Ex=EMAX;
EW=EMAX;
E_old=EMAX+1;
iE=0;
endpoints[iE]=EMAX;
iE++;
gsl_histogram_reset(LG);
//WINDOWS --> <--WINDOWS*******
while((Ex>EMIN)&&(sweep<MAXSWEEPS)){
//initial config
gera_config(Z,sociedade,SIZE,L,r,0);
E_old = hamiltoneana(sociedade,issue,SIZE,L,P,DELTA,graph);
while( (E_old<EMIN+1)||(E_old>Ex) ){
//printf("%d %3.1f\n",E_old);
do{
inow=gsl_rng_uniform_int(r,SIZE);
}while((inow<0)||(inow>=SIZE));
gsl_matrix_get_row(v0,sociedade,inow);
gera_vetor(v1,L,r);
gsl_matrix_set_row(sociedade,inow,v1);
E_old = hamiltoneana(sociedade,issue,SIZE,L,P,DELTA,graph);
if (E_old>Ex){
gsl_matrix_set_row(sociedade,inow,v0);
E_old = hamiltoneana(sociedade,issue,SIZE,L,P,DELTA,graph);
}
//printf("%3.1f %3.1f %3.1f\n",EMIN+1,E_old, Ex);
}
if (SHOWFLAG==1){
printf("# sampling [%f,%f]\n",EMIN,Ex);
printf("# walking from E=%3.0f\n",E_old);
}
fprintf(logfile,"# sampling [%f,%f]\n",EMIN,Ex);
fprintf(logfile,"# walking from E=%3.0f\n",E_old);
do{ //FLAT WINDOW------> <------FLAT WINDOW*****
//MC sweep ----> <------MC sweep********
for(it=0;it<SIZE;it++){
igraph_vector_init(&neighbors,SIZE);
//escolhe sítio aleatoriamente
do{
inow=gsl_rng_uniform_int(r,SIZE);
}while((inow<0)||(inow>=SIZE));
gsl_matrix_get_row(v1,sociedade,inow);
igraph_neighbors(&graph,&neighbors,inow,IGRAPH_OUT);
//gera vetor aleatorio v1
gsl_vector_memcpy(v0,v1);
gera_vetor(v1,L,r);
//calculates energy change when
//v0->v1 in site inow
DeltaE=variacaoE(v0,v1,inow,sociedade,issue,
N,L,P,DELTA,graph,neighbors);
E_new=E_old+DeltaE;
//WL: accepts in [EMIN,Ex]
if ((E_new>EMIN) && (E_new<Ex))
{
gsl_histogram_find(logG,E_old,&i_old);
logG_old=gsl_histogram_get(logG,i_old);
gsl_histogram_find(logG,E_new,&i_new);
logG_new=gsl_histogram_get(logG,i_new);
wE = GSL_MIN(exp(logG_old-logG_new),1);
if (gsl_rng_uniform(r)<wE){
E_old=E_new;
gsl_matrix_set_row(sociedade,inow,v1);
}
}
//WL: updates histograms
gsl_histogram_increment(HE,E_old);
gsl_histogram_accumulate(logG,E_old,lf);
itera++;
igraph_vector_destroy(&neighbors);
}
//MC sweep ----> <--------MC sweep****
sweep++; iverify++;
if( (EMAX-EMIN)<NDE*DE ) {
EW=EMIN;
}else{
EW=GSL_MAX(Ex-w,EMIN);
}
if (iverify==CHECK){//Verify flatness
if (SHOWFLAG==1)
printf(" #verificando flatness em [%f,%f]\n",EW,Ex);
fprintf(logfile," #verificando flatness em [%f,%f]\n"
,EW,Ex);
iverify=0;
flat=flatness(HE,EW,Ex,TOL,itera,meanhist,hvalue);
if (SHOWFLAG==1)
printf("#minH= %8.0f\t k<H>=%8.0f\t %d sweeps\t ",
hvalue,TOL*meanhist,sweep,flat);
fprintf(logfile,
"#minH= %8.0f\t k<H>=%8.0f\t %d sweeps\t ",
hvalue,TOL*meanhist,sweep,flat);
}
}while(flat==0);// <------FLAT WINDOW******
flat=0;
//Find ER
//printf("# EMAX=%f EMIN = %f Ex =%f\n",EMAX, EMIN, Ex);
if( (EMAX-EMIN)<NDE*DE ) {
Ex=EMIN;
endpoints[iE]=EMIN;
}
else {
if (EW>EMIN){
ER=flatwindow(HE,EW,TOL,meanhist);
if (SHOWFLAG==1)
printf("# extending flatness to[%f,%f]\n",ER,Ex);
fprintf(logfile,
"# extending flatness to [%f,%f]\n",ER,Ex);
if((ER-EMIN)<1){
ER=EMIN;
Ex=EMIN;
endpoints[iE]=EMIN;
}else{
endpoints[iE]=GSL_MIN(ER+DE,EMAX);
Ex=GSL_MIN(ER+2*DE,EMAX);
}
}
else{
endpoints[iE]=EMIN;
Ex=EMIN;
ER=EMIN;
}
}
if (SHOWFLAG==1)
printf("# window %d [%3.0f,%3.0f] is flat after %d sweeps \n",
iE,endpoints[iE],endpoints[iE-1],sweep);
fprintf(logfile,"# window %d [%3.0f,%3.0f] is flat after %d sweeps\n",
iE,endpoints[iE],endpoints[iE-1],sweep);
//saves histogram
if (iE==1){
gsl_histogram_find(logG,endpoints[iE],&i1);
gsl_histogram_find(logG,endpoints[iE-1],&i2);
for(i0=i1;i0<=i2;i0++){
lGv=gsl_histogram_get(logG,i0);
gsl_histogram_get_range(logG,i0,&lower,&upper);
E=0.5*(upper+lower);
gsl_histogram_accumulate(LG,E,lGv);
}
}else{
gsl_histogram_find(logG,endpoints[iE],&i1);
gsl_histogram_find(logG,endpoints[iE-1],&i2);
lGv=gsl_histogram_get(logG,i2);
lGvR=gsl_histogram_get(LG,i2);
DlG=lGvR-lGv;
//printf("i1=%d i2=%d lGv=%f lGvR=%f DlG=%f\n",i1,i2,lGv,lGvR,DlG);
for(i0=i1;i0<i2;i0++){
lGv=gsl_histogram_get(logG,i0);
lGv=lGv+DlG;
gsl_histogram_get_range(logG,i0,&lower,&upper);
E=(upper+lower)*0.5;
//printf("i0=%d E=%f lGv=%f\n",i0,E,lGv);
gsl_histogram_accumulate(LG,E,lGv);
}
}
//printf("#########################################\n");
//gsl_histogram_fprintf(stdout,LG,"%g","%g");
//printf("#########################################\n");
iE++;
if((Ex-EMIN)>NDE*DE) {
if (SHOWFLAG==1)
printf("# random walk is now restricted to [%3.0f,%3.0f]\n"
,EMIN,Ex);
fprintf(logfile,"# random walk is now restricted to [%3.0f,%3.0f]\n"
,EMIN,Ex);
}
gsl_histogram_reset(HE);
}
//WINDOWS -->
if(sweep<MAXSWEEPS){
if (SHOWFLAG==1)
printf("# log(f)=%f converged within %d sweeps\n\n",lf,sweep);
fprintf(logfile,"# log(f)=%f converged within %d sweeps\n\n",lf,sweep);
lf=lf/2.0;
gsl_histogram_reset(HE);
gsl_histogram_memcpy(logG,LG);
}else {
if (SHOWFLAG==1)
printf("# FAILED: no convergence has been attained.");
fprintf(logfile,
"# FAILED: no convergence has been attained. Simulation ABANDONED.");
return(1);
}
}while(lf>MINLOGF);
//RESOLUTION --> <-----RESOLUTION****
//*****************************************************************
//Density of states
//*****************************************************************
double minlogG=gsl_histogram_min_val(logG);
gsl_histogram_shift(logG,-minlogG);
gsl_histogram_fprintf(dos,logG,"%g","%g");
//*****************************************************************
//Thermodynamics
//*****************************************************************
double beta,A,wT,Zmin_beta;
double lGvalue,maxA,betaC,CTMAX=0;
double Z_beta,U,U2,CT,F,S;
for (beta=0.01;beta<=30;beta+=0.01)
{
//******************************************************************
//Energy, free-energy, entropy, specific heat and Tc
//******************************************************************
maxA=0;
for (ia2=0; ia2<NBINS;ia2++)
{
lGvalue=gsl_histogram_get(logG,ia2);
gsl_histogram_get_range(logG,ia2,&lower,&upper);
E=(lower+upper)/2;
A=lGvalue-beta*E;
if (A>maxA) maxA=A;
}
gsl_histogram_find(logG,EMIN,&i0);
Z_beta=0;U=0;U2=0;
for (ia2=0; ia2<NBINS;ia2++)
{
lGvalue=gsl_histogram_get(logG,ia2);
gsl_histogram_get_range(logG,ia2,&lower,&upper);
E=(lower+upper)/2;
A=lGvalue-beta*E-maxA;
Z_beta+=exp(A);
U+=E*exp(A);
U2+=E*E*exp(A);
if(ia2==i0) Zmin_beta=exp(A);
}
wT=Zmin_beta/Z_beta;
F=-log(Z_beta)/beta - maxA/beta;
U=U/Z_beta;
S= (U-F)*beta;
U2=U2/Z_beta;
CT=(U2-U*U)*beta*beta;
if(CT>CTMAX){
CTMAX=CT;
betaC=beta;
}
fprintf(thermodynamics,"%f %f %f %f %f %f %f \n"
,beta,1/beta,F/(double)(SIZE),S/(double)(SIZE),
U/(double)(SIZE),CT/(double)(SIZE),wT);
}
if (SHOWFLAG==1) printf("# BETAc: %f Tc:%f \n",betaC,1/betaC);
fprintf(logfile,"# BETAc: %f Tc:%f \n",betaC,1/betaC);
//******************************************************************
//canonical distribuition at Tc
//******************************************************************
beta=betaC;
double distr_canonica;
maxA=0;
for (ia2=0; ia2<NBINS;ia2++)
{
lGvalue=gsl_histogram_get(logG,ia2);
gsl_histogram_get_range(logG,ia2,&lower,&upper);
E=(lower+upper)/2;
A=lGvalue-beta*E;
if (A>maxA) maxA=A;
}
for (ia2=0; ia2<NBINS;ia2++)
{
lGvalue=gsl_histogram_get(logG,ia2);
gsl_histogram_get_range(logG,ia2,&lower,&upper);
E=(lower+upper)/2;
A=lGvalue-beta*E-maxA;
distr_canonica=exp(A);
fprintf(canonical,"%f %f %f\n",
E/(double)(SIZE),distr_canonica,A);
}
//*****************************************************************
// Finalization
//*****************************************************************
igraph_destroy(&graph);
igraph_vector_destroy(&neighbors);
igraph_vector_destroy(&result);
gsl_matrix_free(issue);
gsl_vector_free(current_issue);
gsl_vector_free(v1);
gsl_vector_free(v0);
gsl_matrix_free(sociedade);
gsl_rng_free(r);
fclose(wlsrange);
fclose(dos);
fclose(thermodynamics);
fclose(canonical);
fclose(logfile);
return(0);
}
void bootstrap(double x[], double y[], double* result, int* b, int* B, int *n, int* d) {
static gsl_rng *restrict r = NULL;
if(r == NULL) { // First call to this function, setup RNG
gsl_rng_env_setup();
r = gsl_rng_alloc(gsl_rng_mt19937);
gsl_rng_set(r, time(NULL));
}
//a stores the sampled indices
int a[ *n ];
//allocate memory for the regression step
gsl_matrix * pred = gsl_matrix_alloc ( *n, *d );
gsl_vector * resp = gsl_vector_alloc( *n );
gsl_multifit_linear_workspace * work = gsl_multifit_linear_alloc ( *n, *d );
gsl_vector* coef = gsl_vector_alloc ( *d );
gsl_matrix* cov = gsl_matrix_alloc ( *d, *d );
gsl_matrix * T_boot = gsl_matrix_alloc ( *B, *d );
double chisq;
//create bootstrap samples
for ( int i = 0; i < *B; i++ ) {
//sample the indices
samp_k_from_n( n, b, a, r);
printf("dfdfdfd");
//transfer x to a matrix pred and y to a vector resp
for ( int i = 0; i < *n; i++ ) {
gsl_vector_set (resp, i, y[ a[i] ]);
for (int j = 0; j < *d; j++)
gsl_matrix_set (pred, i, j, x[ j + ( a[ i ] * (*d) ) ]);
}
//linera regression
gsl_multifit_linear ( pred, resp, coef, cov, &chisq, work );
//pass the elements of coef to the ith row of T_boot
gsl_matrix_set_row ( T_boot, i, coef );
}
//compute the standard deviation of each coefficient accros the bootstrap repetitions
for ( int j = 0; j < *d; j++){
result[ j ] = sqrt( gsl_stats_variance( gsl_matrix_ptr ( T_boot, 0, j ), 1, *B ) );
}
//free the memory
gsl_matrix_free (pred);
gsl_vector_free(resp);
gsl_multifit_linear_free ( work);
gsl_vector_free (coef);
//gsl_vector_free (w);
gsl_matrix_free (cov);
printf("\nI AM DONE\n\n");
}
// simplex routine
// f is n dimensional function to be minimised, lower and upper are bounds of coordinates for initial vertices
// simplex_goal_size is tolerance for convergene and W is workspace for simplex routine of dimension n
// out termination the vector W->ce will contain coordinates for lowest vertex
int simplex(double f(gsl_vector* x),double lower, double upper, double simplex_goal_size, simplex_workspace* W)
{
int steps = 0;
double fp1, fp2, flo, fhi;
// initialize system by generating vertices and
// finding their function values
simplex_generate(lower,upper,W);
simplex_initialize(f,W);
do
{
// make an update for higher, lower and centroid
simplex_update(W);
fhi = gsl_vector_get(W->fp,W->hi);
flo = gsl_vector_get(W->fp,W->lo);
// make reflection
reflection(W);
fp1 = f(W->p1);
if (fp1 < flo)
{
// if f(reflected) < f(lower) attempt expansion
expansion(W);
fp2 = f(W->p2);
if (fp2 < fp1)
{
// if f(expanded) < f(reflecred) accept expansion
gsl_matrix_set_row(W->simplex,W->hi,W->p2);
gsl_vector_set(W->fp,W->hi,fp2);
}
else
{
// if not, accept reflection
gsl_matrix_set_row(W->simplex,W->hi,W->p1);
gsl_vector_set(W->fp,W->hi,fp1);
}
}
else
{
if (fp1 < fhi)
{
// if f(reflected) < f(higher) accept reflection
gsl_matrix_set_row(W->simplex,W->hi,W->p1);
gsl_vector_set(W->fp,W->hi,fp1);
}
else
{
// if not, attempt contraction
contraction(W);
fp2 = f(W->p2);
if (fp2 < fhi)
{
// if f(contracted) < f(higher), accept contraction
gsl_matrix_set_row(W->simplex,W->hi,W->p2);
gsl_vector_set(W->fp,W->hi,fp2);
}
else
{
// if not, we must be in a valley, perform reduction
reduction(f,W);
}
}
}
steps++;
// if simplex has reduced sufficiently, that is size(simplex) < simplex_goal_size
// convergence is achieved. Return number of steps before convergence.
} while (simplex_size(W) > simplex_goal_size);
// copy lowest vertex to centroid vector
gsl_matrix_get_row(W->ce,W->simplex,W->lo);
return steps;
}
int PoissonGlm::betaEst( unsigned int id, unsigned int iter, double *tol, double th)
{
gsl_set_error_handler_off();
int status, isValid;
// unsigned int j, ngoodobs;
unsigned int i, step, step1;
double wij, zij, eij, mij, yij; //, bij;
double dev_old, dev_grad=1.0;
gsl_vector_view Xwi;
gsl_matrix *WX, *XwX;
gsl_vector *z, *Xwz;
gsl_vector *coef_old = gsl_vector_alloc(nParams);
gsl_vector_view bj=gsl_matrix_column (Beta, id);
// Main Loop of IRLS begins
z = gsl_vector_alloc(nRows);
WX = gsl_matrix_alloc(nRows, nParams);
XwX = gsl_matrix_alloc(nParams, nParams);
Xwz = gsl_vector_alloc(nParams);
step=0;
*tol = 1.0;
gsl_vector_memcpy (coef_old, &bj.vector);
while ( step<iter ) {
for (i=0; i<nRows; i++) { // (y-m)/g'
yij = gsl_matrix_get(Yref, i, id);
eij = gsl_matrix_get(Eta, i, id);
mij = gsl_matrix_get(Mu, i, id);
// if (mij<mintol) mij=mintol;
// if (mij>maxtol) mij=maxtol;
zij = eij + (yij-mij)*LinkDash(mij);
if (Oref!=NULL)
zij = zij - gsl_matrix_get(Oref, i, id);
// wt=sqrt(weifunc);
wij = sqrt(weifunc(mij, th));
// W^1/2*z[good]
gsl_vector_set(z, i, wij*zij);
// W^1/2*X[good]
Xwi = gsl_matrix_row (Xref, i);
gsl_matrix_set_row (WX, i, &Xwi.vector);
Xwi = gsl_matrix_row (WX, i);
gsl_vector_scale(&Xwi.vector, wij);
}
// in glm2, solve WXb=Wz, David suggested not good
// So back to solving X'WXb=X'Wz
gsl_matrix_set_identity (XwX);
gsl_blas_dsyrk (CblasLower,CblasTrans,1.0,WX,0.0,XwX);
status=gsl_linalg_cholesky_decomp(XwX);
if (status==GSL_EDOM) {
if (mmRef->warning==TRUE) {
printf("Warning: singular matrix in betaEst: ");
gsl_matrix_set_identity (XwX);
gsl_blas_dsyrk (CblasLower,CblasTrans,1.0,Xref,0.0,XwX);
// displaymatrix(Xref, "Xref");
// displaymatrix(XwX, "XX^T");
// printf("calc(XX')=%.8f\n", calcDet(XwX));
status=gsl_linalg_cholesky_decomp(XwX);
if (status==GSL_EDOM)
printf("X^TX is singular - check case resampling or input design matrix!\n");
else {
for (i=0; i<nRows; i++) {
mij = gsl_matrix_get(Mu, i, id);
wij = sqrt(weifunc(mij, th));
if (wij<mintol) printf("weight[%d, %d]=%.4f is too close to zero\n", i, id, wij);
}
}
printf("An eps*I is added to the singular matrix.\n");
}
gsl_matrix_set_identity (XwX);
gsl_blas_dsyrk (CblasLower,CblasTrans,1.0,WX,mintol,XwX);
gsl_linalg_cholesky_decomp(XwX);
}
gsl_blas_dgemv(CblasTrans,1.0,WX,z,0.0,Xwz);
gsl_linalg_cholesky_solve (XwX, Xwz, &bj.vector);
// Debug for nan
/* if (gsl_vector_get(&bj.vector, 1)!=gsl_vector_get(&bj.vector, 1)) {
displayvector(&bj.vector, "bj");
displayvector(z, "z");
gsl_vector_view mj=gsl_matrix_column(Mu, id);
displayvector(&mj.vector, "mj");
printf("weight\n");
for (i=0; i<nRows; i++){
printf("%.4f ", sqrt(weifunc(mij, th)));
}
printf("\n");
displaymatrix(XwX, "XwX");
exit(-1);
}
*/
// Given bj, update eta, mu
dev_old = dev[id];
isValid=predict(bj, id, th);
dev_grad=(dev[id]-dev_old)/(ABS(dev[id])+0.1);
*(tol)=ABS(dev_grad);
step1 = 0;
// If divergent or increasing deviance, half step
// (step>1) -> (step>0) gives weired results for NBin fit
// below works for boundary values, esp BIN fit but not NBin fit
while ((dev_grad>eps)&(step>1)){
gsl_vector_add (&bj.vector, coef_old);
gsl_vector_scale (&bj.vector, 0.5);
// dev_old=dev[id];
isValid=predict(bj, id, th);
dev_grad=(dev[id]-dev_old)/(ABS(dev[id])+0.1);
*tol=ABS(dev_grad);
if (*tol<eps) break;
step1++;
if (step1>10) {
// printf("\t Half step stopped at iter %d: gradient=%.8f\n", step1, dev_grad);
break;
}
}
if (isValid==TRUE) gsl_vector_memcpy (coef_old, &bj.vector);
step++;
if (*tol<eps) break;
}
gsl_vector_free(z);
gsl_matrix_free(WX);
gsl_matrix_free(XwX);
gsl_vector_free(Xwz);
gsl_vector_free(coef_old);
return step;
}
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;
}
int AnovaTest::resampTest(void)
{
// printf("Start resampling test ...\n");
unsigned int i, j, p, id;
unsigned int maxiter=mmRef->nboot;
double hii, score;
gsl_matrix *bX, *bY;
bY = gsl_matrix_alloc(nRows, nVars);
bX = gsl_matrix_alloc(nRows, nParam);
// initialize permid
unsigned int *permid=NULL;
if ( bootID == NULL ) {
if ( mmRef->resamp == PERMUTE ){
permid = (unsigned int *)malloc(nRows*sizeof(unsigned int));
for (i=0; i<nRows; i++)
permid[i] = i;
} }
// else
// displaymatrix(bootID, "bootID received");
// resampling options
if (mmRef->resamp == CASEBOOT) {
nSamp = 0;
for (i=0; i<maxiter; i++) {
for ( j=0; j<nRows; j++ ){
// resampling index
if (bootID == NULL)
id = gsl_rng_uniform_int(rnd, nRows);
else
id = (unsigned int) gsl_matrix_get(bootID, i, j);
// resample Y and X
gsl_vector_view Yj=gsl_matrix_row(Yref, id);
gsl_matrix_set_row (bY, j, &Yj.vector);
gsl_vector_view Xj=gsl_matrix_row(Xref, id);
gsl_matrix_set_row (bX, j, &Xj.vector);
}
anovacase(bY, bX);
nSamp++;
}
}
else if (mmRef->resamp == RESIBOOT) {
nSamp = 0;
for (i=0; i<maxiter; i++) {
for (p=1; p<nModels; p++) {
if (mmRef->reprand!=TRUE) {
GetRNGstate();
printf("reprand==FALSE\n");
}
for (j=0; j<nRows; j++){
// resampling index
if (bootID == NULL)
id = gsl_rng_uniform_int(rnd, nRows);
else
id = (unsigned int) gsl_matrix_get(bootID, i, j);
// bootr by resampling resi=(Y-fit)
gsl_vector_view Yj=gsl_matrix_row(Yref, id);
gsl_vector_view Fj=gsl_matrix_row(Hats[p].Y, id);
gsl_matrix_set_row (bY, j, &Yj.vector);
gsl_vector_view bootr=gsl_matrix_row(bY, j);
gsl_vector_sub (&bootr.vector, &Fj.vector);
if (mmRef->student==TRUE) {
hii = gsl_matrix_get(Hats[p].mat, id, id);
gsl_vector_scale (&bootr.vector, 1/sqrt(1-hii));
}
// bY = Y + bootr
Yj=gsl_matrix_row(Hats[p].Y, j);
gsl_vector_add (&bootr.vector, &Yj.vector);
}
if (mmRef->reprand!=TRUE) PutRNGstate();
anovaresi(bY, p);
}
nSamp++;
} }
else if (mmRef->resamp == SCOREBOOT) {
nSamp = 0;
for (i=0; i<maxiter; i++) {
for (p=1; p<nModels; p++) {
for ( j=0; j<nRows; j++ ) {
// random score
if ( bootID == NULL )
score = gsl_ran_ugaussian (rnd);
else
score = (double)gsl_matrix_get(bootID, i, j);
// bootr = (Y - fit)*score
gsl_vector_view Yj=gsl_matrix_row(Yref, j);
gsl_vector_view Fj=gsl_matrix_row(Hats[p].Y, j);
gsl_matrix_set_row (bY, j, &Yj.vector);
gsl_vector_view bootr=gsl_matrix_row(bY, j);
gsl_vector_sub (&bootr.vector, &Fj.vector);
if (mmRef->student==TRUE) {
hii = gsl_matrix_get(Hats[p].mat, j, j);
gsl_vector_scale (&bootr.vector, 1/sqrt(1-hii));
}
// bY = Y + bootr
gsl_vector_scale (&bootr.vector, score);
gsl_vector_add (&bootr.vector, &Fj.vector);
}
anovaresi(bY, p);
}
nSamp++;
} }
else if ( mmRef->resamp == PERMUTE ) {
gsl_matrix_add_constant (Pstatj, 1.0);
for (p=0; p<nModels-1; p++)
Pmultstat[p]=1.0; // include itself
nSamp = 1;
for (i=0; i<maxiter-1; i++) { //999
for (p=1; p<nModels; p++){
if (bootID == NULL )
gsl_ran_shuffle(rnd, permid, nRows, sizeof(unsigned int));
// get bootr by permuting resi:Y-fit
for (j=0; j<nRows; j++){
if (bootID == NULL)
id = permid[j];
else
id = (unsigned int) gsl_matrix_get(bootID, i, j);
// bootr by resampling resi=(Y-fit)
gsl_vector_view Yj=gsl_matrix_row(Yref, id);
gsl_vector_view Fj=gsl_matrix_row(Hats[p].Y, id);
gsl_matrix_set_row (bY, j, &Yj.vector);
gsl_vector_view bootr=gsl_matrix_row(bY, j);
gsl_vector_sub (&bootr.vector, &Fj.vector);
if (mmRef->student==TRUE) {
hii = gsl_matrix_get(Hats[p].mat, id, id);
gsl_vector_scale (&bootr.vector, 1/sqrt(1-hii));
}
// bY = Y + bootr
Yj=gsl_matrix_row(Hats[p].Y, j);
gsl_vector_add (&bootr.vector, &Yj.vector);
}
anovaresi(bY, p);
}
nSamp++;
}
}
else
GSL_ERROR("Invalid resampling option", GSL_EINVAL);
// p-values
unsigned int sid, sid0;
double *pj;
for (i=0; i<nModels-1; i++) {
Pmultstat[i]=(double) (Pmultstat[i]+1)/(nSamp+1); // adjusted with +1
pj = gsl_matrix_ptr (Pstatj, i, 0);
if ( mmRef->punit == FREESTEP ){
for (j=1; j<nVars; j++){
sid = gsl_permutation_get(sortid[i], j);
sid0 = gsl_permutation_get(sortid[i], j-1);
*(pj+sid)=MAX(*(pj+sid), *(pj+sid0));
}
}
if ( mmRef->punit == STEPUP ){
for (j=2; j<nVars; j++){
sid = gsl_permutation_get(sortid[i], nVars-j);
sid0 = gsl_permutation_get(sortid[i], nVars-j+1);
*(pj+sid) = MIN(*(pj+sid), *(pj+sid0));
}
}
for (j=0; j<nVars; j++)
*(pj+j) = (double)(*(pj+j)+1)/(nSamp+1); // adjusted with +1
}
// free memory
gsl_matrix_free(bX);
gsl_matrix_free(bY);
if (permid!=NULL) free(permid);
return 0;
}
void fnIMIS(const size_t InitSamples, const size_t StepSamples, const size_t FinalResamples, const size_t MaxIter, const size_t NumParam, unsigned long int rng_seed, const char * runName)
{
// Declare and configure GSL RNG
gsl_rng * rng;
const gsl_rng_type * T;
gsl_rng_env_setup();
T = gsl_rng_default;
rng = gsl_rng_alloc (T);
gsl_rng_set(rng, rng_seed);
char strDiagnosticsFile[strlen(runName) + 15 +1];
char strResampleFile[strlen(runName) + 12 +1];
strcpy(strDiagnosticsFile, runName); strcat(strDiagnosticsFile, "Diagnostics.txt");
strcpy(strResampleFile, runName); strcat(strResampleFile, "Resample.txt");
FILE * diagnostics_file = fopen(strDiagnosticsFile, "w");
fprintf(diagnostics_file, "Seeded RNG: %zu\n", rng_seed);
fprintf(diagnostics_file, "Running IMIS. InitSamples: %zu, StepSamples: %zu, FinalResamples %zu, MaxIter %zu\n", InitSamples, StepSamples, FinalResamples, MaxIter);
// Setup IMIS arrays
gsl_matrix * Xmat = gsl_matrix_alloc(InitSamples + StepSamples*MaxIter, NumParam);
double * prior_all = (double*) malloc(sizeof(double) * (InitSamples + StepSamples*MaxIter));
double * likelihood_all = (double*) malloc(sizeof(double) * (InitSamples + StepSamples*MaxIter));
double * imp_weight_denom = (double*) malloc(sizeof(double) * (InitSamples + StepSamples*MaxIter)); // proportional to q(k) in stage 2c of Raftery & Bao
double * gaussian_sum = (double*) calloc(InitSamples + StepSamples*MaxIter, sizeof(double)); // sum of mixture distribution for mode
struct dst * distance = (struct dst *) malloc(sizeof(struct dst) * (InitSamples + StepSamples*MaxIter)); // Mahalanobis distance to most recent mode
double * imp_weights = (double*) malloc(sizeof(double) * (InitSamples + StepSamples*MaxIter));
double * tmp_MVNpdf = (double*) malloc(sizeof(double) * (InitSamples + StepSamples*MaxIter));
gsl_matrix * nearestX = gsl_matrix_alloc(StepSamples, NumParam);
double center_all[MaxIter][NumParam];
gsl_matrix * sigmaChol_all[MaxIter];
gsl_matrix * sigmaInv_all[MaxIter];
// Initial prior samples
sample_prior(rng, InitSamples, Xmat);
// Calculate prior covariance
double prior_invCov_diag[NumParam];
/*
The paper describing the algorithm uses the full prior covariance matrix.
This follows the code in the IMIS R package and diagonalizes the prior
covariance matrix to ensure invertibility.
*/
for(size_t i = 0; i < NumParam; i++){
gsl_vector_view tmpCol = gsl_matrix_subcolumn(Xmat, i, 0, InitSamples);
prior_invCov_diag[i] = gsl_stats_variance(tmpCol.vector.data, tmpCol.vector.stride, InitSamples);
prior_invCov_diag[i] = 1.0/prior_invCov_diag[i];
}
// IMIS steps
fprintf(diagnostics_file, "Step Var(w_i) MargLik Unique Max(w_i) ESS Time\n");
printf("Step Var(w_i) MargLik Unique Max(w_i) ESS Time\n");
time_t time1, time2;
time(&time1);
size_t imisStep = 0, numImisSamples;
for(imisStep = 0; imisStep < MaxIter; imisStep++){
numImisSamples = (InitSamples + imisStep*StepSamples);
// Evaluate prior and likelihood
if(imisStep == 0){ // initial stage
#pragma omp parallel for
for(size_t i = 0; i < numImisSamples; i++){
gsl_vector_const_view theta = gsl_matrix_const_row(Xmat, i);
prior_all[i] = prior(&theta.vector);
likelihood_all[i] = likelihood(&theta.vector);
}
} else { // imisStep > 0
#pragma omp parallel for
for(size_t i = InitSamples + (imisStep-1)*StepSamples; i < numImisSamples; i++){
gsl_vector_const_view theta = gsl_matrix_const_row(Xmat, i);
prior_all[i] = prior(&theta.vector);
likelihood_all[i] = likelihood(&theta.vector);
}
}
// Determine importance weights, find current maximum, calculate monitoring criteria
#pragma omp parallel for
for(size_t i = 0; i < numImisSamples; i++){
imp_weight_denom[i] = (InitSamples*prior_all[i] + StepSamples*gaussian_sum[i])/(InitSamples + StepSamples * imisStep);
imp_weights[i] = (prior_all[i] > 0)?likelihood_all[i]*prior_all[i]/imp_weight_denom[i]:0;
}
double sumWeights = 0.0;
for(size_t i = 0; i < numImisSamples; i++){
sumWeights += imp_weights[i];
}
double maxWeight = 0.0, varImpW = 0.0, entropy = 0.0, expectedUnique = 0.0, effSampSize = 0.0, margLik;
size_t maxW_idx;
#pragma omp parallel for reduction(+: varImpW, entropy, expectedUnique, effSampSize)
for(size_t i = 0; i < numImisSamples; i++){
imp_weights[i] /= sumWeights;
varImpW += pow(numImisSamples * imp_weights[i] - 1.0, 2.0);
entropy += imp_weights[i] * log(imp_weights[i]);
expectedUnique += (1.0 - pow((1.0 - imp_weights[i]), FinalResamples));
effSampSize += pow(imp_weights[i], 2.0);
}
for(size_t i = 0; i < numImisSamples; i++){
if(imp_weights[i] > maxWeight){
maxW_idx = i;
maxWeight = imp_weights[i];
}
}
for(size_t i = 0; i < NumParam; i++)
center_all[imisStep][i] = gsl_matrix_get(Xmat, maxW_idx, i);
varImpW /= numImisSamples;
entropy = -entropy / log(numImisSamples);
effSampSize = 1.0/effSampSize;
margLik = log(sumWeights/numImisSamples);
fprintf(diagnostics_file, "%4zu %8.2f %8.2f %8.2f %8.2f %8.2f %8.2f\n", imisStep, varImpW, margLik, expectedUnique, maxWeight, effSampSize, difftime(time(&time2), time1));
printf("%4zu %8.2f %8.2f %8.2f %8.2f %8.2f %8.2f\n", imisStep, varImpW, margLik, expectedUnique, maxWeight, effSampSize, difftime(time(&time2), time1));
time1 = time2;
// Check for convergence
if(expectedUnique > FinalResamples*(1.0 - exp(-1.0))){
break;
}
// Calculate Mahalanobis distance to current mode
GetMahalanobis_diag(Xmat, center_all[imisStep], prior_invCov_diag, numImisSamples, NumParam, distance);
// Find StepSamples nearest points
// (Note: this was a major bottleneck when InitSamples and StepResamples are large. qsort substantially outperformed GSL sort options.)
qsort(distance, numImisSamples, sizeof(struct dst), cmp_dst);
#pragma omp parallel for
for(size_t i = 0; i < StepSamples; i++){
gsl_vector_const_view tmpX = gsl_matrix_const_row(Xmat, distance[i].idx);
gsl_matrix_set_row(nearestX, i, &tmpX.vector);
}
// Calculate weighted covariance of nearestX
// (a) Calculate weights for nearest points 1...StepSamples
double weightsCov[StepSamples];
#pragma omp parallel for
for(size_t i = 0; i < StepSamples; i++){
weightsCov[i] = 0.5*(imp_weights[distance[i].idx] + 1.0/numImisSamples); // cov_wt function will normalize the weights
}
// (b) Calculate weighted covariance
sigmaChol_all[imisStep] = gsl_matrix_alloc(NumParam, NumParam);
covariance_weighted(nearestX, weightsCov, StepSamples, center_all[imisStep], NumParam, sigmaChol_all[imisStep]);
// (c) Do Cholesky decomposition and inverse of covariance matrix
gsl_linalg_cholesky_decomp(sigmaChol_all[imisStep]);
for(size_t j = 0; j < NumParam; j++) // Note: GSL outputs a symmetric matrix rather than lower tri, so have to set upper tri to zero
for(size_t k = j+1; k < NumParam; k++)
gsl_matrix_set(sigmaChol_all[imisStep], j, k, 0.0);
sigmaInv_all[imisStep] = gsl_matrix_alloc(NumParam, NumParam);
gsl_matrix_memcpy(sigmaInv_all[imisStep], sigmaChol_all[imisStep]);
gsl_linalg_cholesky_invert(sigmaInv_all[imisStep]);
// Sample new inputs
gsl_matrix_view newSamples = gsl_matrix_submatrix(Xmat, numImisSamples, 0, StepSamples, NumParam);
GenerateRandMVnorm(rng, StepSamples, center_all[imisStep], sigmaChol_all[imisStep], NumParam, &newSamples.matrix);
// Evaluate sampling probability from mixture distribution
// (a) For newly sampled points, sum over all previous centers
for(size_t pastStep = 0; pastStep < imisStep; pastStep++){
GetMVNpdf(&newSamples.matrix, center_all[pastStep], sigmaInv_all[pastStep], sigmaChol_all[pastStep], StepSamples, NumParam, tmp_MVNpdf);
#pragma omp parallel for
for(size_t i = 0; i < StepSamples; i++)
gaussian_sum[numImisSamples + i] += tmp_MVNpdf[i];
}
// (b) For all points, add weight for most recent center
gsl_matrix_const_view Xmat_curr = gsl_matrix_const_submatrix(Xmat, 0, 0, numImisSamples + StepSamples, NumParam);
GetMVNpdf(&Xmat_curr.matrix, center_all[imisStep], sigmaInv_all[imisStep], sigmaChol_all[imisStep], numImisSamples + StepSamples, NumParam, tmp_MVNpdf);
#pragma omp parallel for
for(size_t i = 0; i < numImisSamples + StepSamples; i++)
gaussian_sum[i] += tmp_MVNpdf[i];
} // loop over imisStep
//// FINISHED IMIS ROUTINE
fclose(diagnostics_file);
// Resample posterior outputs
int resampleIdx[FinalResamples];
walker_ProbSampleReplace(rng, numImisSamples, imp_weights, FinalResamples, resampleIdx); // Note: Random sampling routine used in R sample() function.
// Print results
FILE * resample_file = fopen(strResampleFile, "w");
for(size_t i = 0; i < FinalResamples; i++){
for(size_t j = 0; j < NumParam; j++)
fprintf(resample_file, "%.15e\t", gsl_matrix_get(Xmat, resampleIdx[i], j));
gsl_vector_const_view theta = gsl_matrix_const_row(Xmat, resampleIdx[i]);
fprintf(resample_file, "\n");
}
fclose(resample_file);
/*
// This outputs Xmat (parameter matrix), centers, and covariance matrices to files for debugging
FILE * Xmat_file = fopen("Xmat.txt", "w");
for(size_t i = 0; i < numImisSamples; i++){
for(size_t j = 0; j < NumParam; j++)
fprintf(Xmat_file, "%.15e\t", gsl_matrix_get(Xmat, i, j));
fprintf(Xmat_file, "%e\t%e\t%e\t%e\t%e\t\n", prior_all[i], likelihood_all[i], imp_weights[i], gaussian_sum[i], distance[i]);
}
fclose(Xmat_file);
FILE * centers_file = fopen("centers.txt", "w");
for(size_t i = 0; i < imisStep; i++){
for(size_t j = 0; j < NumParam; j++)
fprintf(centers_file, "%f\t", center_all[i][j]);
fprintf(centers_file, "\n");
}
fclose(centers_file);
FILE * sigmaInv_file = fopen("sigmaInv.txt", "w");
for(size_t i = 0; i < imisStep; i++){
for(size_t j = 0; j < NumParam; j++)
for(size_t k = 0; k < NumParam; k++)
fprintf(sigmaInv_file, "%f\t", gsl_matrix_get(sigmaInv_all[i], j, k));
fprintf(sigmaInv_file, "\n");
}
fclose(sigmaInv_file);
*/
// free memory allocated by IMIS
for(size_t i = 0; i < imisStep; i++){
gsl_matrix_free(sigmaChol_all[i]);
gsl_matrix_free(sigmaInv_all[i]);
}
// release RNG
gsl_rng_free(rng);
gsl_matrix_free(Xmat);
gsl_matrix_free(nearestX);
free(prior_all);
free(likelihood_all);
free(imp_weight_denom);
free(gaussian_sum);
free(distance);
free(imp_weights);
free(tmp_MVNpdf);
return;
}
