static int
pcholesky_decomp (const int copy_uplo, gsl_matrix * A, gsl_permutation * p)
{
const size_t N = A->size1;
if (N != A->size2)
{
GSL_ERROR("LDLT decomposition requires square matrix", GSL_ENOTSQR);
}
else if (p->size != N)
{
GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN);
}
else
{
gsl_vector_view diag = gsl_matrix_diagonal(A);
size_t k;
if (copy_uplo)
{
/* save a copy of A in upper triangle (for later rcond calculation) */
gsl_matrix_transpose_tricpy('L', 0, A, A);
}
gsl_permutation_init(p);
for (k = 0; k < N; ++k)
{
gsl_vector_view w;
size_t j;
/* compute j = max_idx { A_kk, ..., A_nn } */
w = gsl_vector_subvector(&diag.vector, k, N - k);
j = gsl_vector_max_index(&w.vector) + k;
gsl_permutation_swap(p, k, j);
cholesky_swap_rowcol(A, k, j);
if (k < N - 1)
{
double alpha = gsl_matrix_get(A, k, k);
double alphainv = 1.0 / alpha;
/* v = A(k+1:n, k) */
gsl_vector_view v = gsl_matrix_subcolumn(A, k, k + 1, N - k - 1);
/* m = A(k+1:n, k+1:n) */
gsl_matrix_view m = gsl_matrix_submatrix(A, k + 1, k + 1, N - k - 1, N - k - 1);
/* m = m - v v^T / alpha */
gsl_blas_dsyr(CblasLower, -alphainv, &v.vector, &m.matrix);
/* v = v / alpha */
gsl_vector_scale(&v.vector, alphainv);
}
}
return GSL_SUCCESS;
}
}
static VALUE rb_gsl_permutation_init(VALUE obj)
{
gsl_permutation *p = NULL;
Data_Get_Struct(obj, gsl_permutation, p);
gsl_permutation_init(p);
return obj;
}
void mexFunction(int nlhs, mxArray *plhs[], int nrhs, const mxArray
*prhs[])
{
int i, j;
int N, Nperm;
int *d;
int subs[2];
double *ptr;
gsl_permutation *c;
if(nrhs != 1)
mexErrMsgTxt("1 input required");
if(nlhs != 1)
mexErrMsgTxt("Requires one output.");
if(mxGetM(prhs[0]) * mxGetN(prhs[0]) != 1)
mexErrMsgTxt("N must be scalar");
N = mxGetScalar(prhs[0]);
Nperm = (int) (gsl_sf_fact(N));
c = gsl_permutation_calloc (N);
gsl_permutation_init(c);
plhs[0] = mxCreateDoubleMatrix(Nperm, N, mxREAL);
ptr = mxGetPr(plhs[0]);
for(i = 0; i < Nperm; i++)
{
d = gsl_permutation_data(c);
for(j = 0; j < N; j++)
{
subs[0] = i;
subs[1] = j;
ptr[mxCalcSingleSubscript(plhs[0], 2, subs)] =
(double)d[j] + 1.;
}
gsl_permutation_next(c);
}
gsl_permutation_free(c);
}
int
main (void)
{
gsl_permutation * p = gsl_permutation_alloc (3) ;
gsl_permutation_init (p) ;
do
{
gsl_permutation_fprintf (stdout, p, " %u") ;
printf("\n") ;
}
while (gsl_permutation_next(p) == GSL_SUCCESS);
}
/* read the configuration file and the graph */
chaincolln chaincolln_readdata(void) {
FILE *fileptr, *initzsfile;
int i, j, k, ndom, nreln, d, r, nitem, dim, maxclass, initclass, relcl, ndim,
domlabel, clusterflag, itemind, nchains, cind, zind;
int *domlabels, *participants, participant;
double val;
double nig[DISTSIZE];
domain *doms;
relation rn;
int *initclasses, ***edgecounts, *relsizes;
char prefix[MAXSTRING];
chaincolln cc;
chain c, c0;
#ifdef GSL
gsl_rng *rng;
const gsl_rng_type *T;
gsl_permutation *perm ;
size_t N;
gsl_rng_env_setup();
T = gsl_rng_default;
rng = gsl_rng_alloc(T);
#endif
fprintf(stdout,"A\n");
nchains = ps.nchains+1;
nig[0] = ps.m; nig[1] = ps.v; nig[2] = ps.a; nig[3] = ps.b;
fileptr = fopen(ps.configfile,"r");
if (fileptr == NULL) {
fprintf(stderr, "couldn't read config file\n"); exit(1);
}
/* initial read of ps.configfile to get ps.maxdim, ps.maxrel, ps.maxitem,
ps.maxclass */
fscanf(fileptr, "%s", prefix);
fscanf(fileptr, "%d %d", &ndom, &nreln);
relsizes= (int *) my_malloc(nreln*sizeof(int));
ps.maxrel = nreln;
ps.maxitem = 0; ps.maxclass = 0;
for (d = 0; d < ndom; d++) {
fscanf(fileptr, "%d %d %d %d", &nitem, &maxclass, &initclass, &clusterflag);
if (nitem > ps.maxitem) {
ps.maxitem = nitem;
}
if (maxclass > ps.maxclass) {
ps.maxclass= maxclass;
}
}
fprintf(stdout,"B\n");
ps.maxdim = 0;
for (r = 0; r < nreln; r++) {
fscanf(fileptr, "%d", &ndim);
relsizes[r] = ndim;
if (ndim > ps.maxdim) {
ps.maxdim = ndim;
}
for (dim=0; dim < ndim; dim++) {
fscanf(fileptr, "%d", &domlabel);
}
}
fclose(fileptr);
fprintf(stdout,"C\n");
domlabels= (int *) my_malloc(ps.maxdim*sizeof(int));
participants= (int *) my_malloc(ps.maxdim*sizeof(int));
initclasses = (int *) my_malloc(ps.maxitem*sizeof(int));
fprintf(stdout,"D \n");
/* initial read of ps.graphname to get ps.maxobjtuples */
edgecounts = (int ***) my_malloc(ps.maxrel*sizeof(int **));
for (i = 0; i < ps.maxrel; i++) {
edgecounts[i] = (int **) my_malloc(ps.maxdim*sizeof(int *));
for (j = 0; j < ps.maxdim; j++) {
edgecounts[i][j] = (int *) my_malloc(ps.maxitem*sizeof(int));
for (k = 0; k < ps.maxitem; k++) {
edgecounts[i][j][k] = 0;
}
}
}
ps.maxobjtuples = 0;
fprintf(stdout,"D2 \n");
fileptr = fopen(ps.graphname,"r");
if (fileptr == NULL) {
fprintf(stderr, "couldn't read graph\n"); exit(1);
}
while( fscanf( fileptr, " %d", &r)!=EOF ) {
fprintf(stdout,"%s %d %d\n",__FILE__,__LINE__,r);
ndim = relsizes[r];
fprintf(stdout,"%s %d %d\n",__FILE__,__LINE__,ndim);
for (dim = 0; dim < ndim; dim++) {
fscanf(fileptr, "%d", &participant);
participants[dim] = participant;
}
fscanf(fileptr, "%lf", &val);
for (dim = 0; dim < ndim; dim++) {
fprintf(stdout,"D2 %d %d %d \n",r,dim,participants[dim]);
edgecounts[r][dim][participants[dim]]++;
fprintf(stdout,"D2 %d %d %d \n",r,dim,participants[dim]);
}
}
fprintf(stdout,"E\n");
fclose(fileptr);
for (i = 0; i < ps.maxrel; i++) {
for (j = 0; j < ps.maxdim; j++) {
for (k = 0; k < ps.maxitem; k++) {
if (edgecounts[i][j][k] > ps.maxobjtuples) {
ps.maxobjtuples = edgecounts[i][j][k];
}
edgecounts[i][j][k]= 0;
}
}
}
fprintf(stdout,"F\n");
free(relsizes);
for (i = 0; i < ps.maxrel; i++) {
for (j = 0; j < ps.maxdim; j++) {
free(edgecounts[i][j]);
}
free(edgecounts[i]);
}
free(edgecounts);
fprintf(stdout,"G\n");
/* second read of ps.configfile where we set up datastructures */
fileptr = fopen(ps.configfile,"r");
if (ps.outsideinit) {
initzsfile= fopen(ps.initfile,"r");
if (initzsfile == NULL) {
fprintf(stderr, "couldn't read initzsfile\n"); exit(1);
}
} else {
initzsfile = NULL;
}
fprintf(stdout,"H\n");
fscanf(fileptr, "%s", prefix);
fscanf(fileptr, "%d %d", &ndom, &nreln);
cc = chaincolln_create(nchains, ndom, nreln, prefix);
c0 = chaincolln_getchain(cc, 0);
fprintf(stdout,"I\n");
/* read domains */
/* input file: nitem maxclass initclass clusterflag*/
for (d = 0; d < ndom; d++) {
fscanf(fileptr, "%d %d %d %d", &nitem, &maxclass, &initclass, &clusterflag);
#ifdef GSL
N = nitem;
#endif
if (ps.outsideinit) {
for (zind = 0; zind < nitem; zind++) {
fscanf(initzsfile, "%d", &initclasses[zind]);
}
}
fprintf(stdout,"J\n");
/* add domains and items to chains */
for (cind = 0; cind < nchains; cind++) {
c = chaincolln_getchain(cc, cind);
chain_adddomain(c, d, nitem, maxclass, clusterflag, ps.alpha,
ps.alphahyp, initclasses);
#ifdef GSL
perm = gsl_permutation_alloc(N);
gsl_permutation_init(perm);
gsl_ran_shuffle(rng, perm->data, N, sizeof(size_t));
#endif
/* assign items to classes */
relcl = 0;
for (i = 0; i < nitem; i++) {
if (ps.outsideinit) {
chain_additemtoclass(c, d, i, initclasses[i]);
} else {
if (relcl == initclass) relcl = 0;
/* without the GNUSL, each chain gets initialized the same way. This
* is suboptimal */
itemind = i;
#ifdef GSL
itemind = gsl_permutation_get(perm, i);
#endif
chain_additemtoclass(c, d, itemind, relcl);
relcl++;
}
}
#ifdef GSL
gsl_permutation_free(perm);
#endif
}
}
#ifdef GSL
gsl_rng_free(rng);
#endif
fprintf(stdout,"K\n");
/* read relations*/
/* input file: ndim d0 ... dn */
for (r = 0; r < nreln; r++) {
fscanf(fileptr, "%d", &ndim);
for (dim=0; dim < ndim; dim++) {
fscanf(fileptr, "%d", &domlabel);
domlabels[dim] = domlabel;
}
for (cind = 0; cind < nchains; cind++) {
c = chaincolln_getchain(cc, cind);
chain_addrelation(c, r, ndim, ps.betaprop, ps.betamag, nig, domlabels);
}
}
if (ps.outsideinit) {
fclose(initzsfile);
}
fprintf(stdout,"L\n");
fclose(fileptr);
/* second read of ps.graphname: store edges*/
fileptr = fopen(ps.graphname,"r");
/* input file: relind p0 p1 p2 .. pn val */
while( fscanf( fileptr, " %d", &r)!= EOF ) {
ndim = relation_getdim( chain_getrelation(c0, r) );
doms = relation_getdoms( chain_getrelation(c0, r) );
for (dim = 0; dim < ndim; dim++) {
fscanf(fileptr, "%d", &participant);
fprintf(stdout,"M %d %d\n",dim,participant);
participants[dim] = participant;
domlabels[dim] = domain_getlabel(doms[dim]);
}
for (i = 0; i < ndim; i++) {
for (j = 0; j < i; j++) {
if (participants[i] == participants[j] &&
domlabels[i] == domlabels[j]) {
fprintf(stderr, "Self links not allowed.\n"); exit(1);
}
}
}
fscanf(fileptr, "%lf", &val);
fprintf(stderr,"%d\n",nchains);
for (cind = 0; cind < nchains; cind++) {
c = chaincolln_getchain(cc, cind);
chain_addedge(c, r, val, participants);
rn = chain_getrelation(c, r);
if (doubleeq(val, 0)) {
relation_setmissing(rn, 1);
}
if (val > 1.5 && relation_getdtype(rn) != CONT) {
relation_setdtype(rn, FREQ);
}
if (!doubleeq(val, (int) val)) {
relation_setdtype(rn, CONT);
relation_setmissing(rn, 1); /* XXX: no sparse continuous matrices */
}
}
}
fprintf(stderr,"N\n");
fclose(fileptr);
for (cind = 0; cind < nchains; cind++) {
c = chaincolln_getchain(cc, cind);
for (i = 0; i < chain_getndomains(c); i++) {
chain_updatedomprobs(c, i);
}
}
fprintf(stderr,"O\n");
free(domlabels); free(participants); free(initclasses);
return cc;
}
int
gsl_linalg_PTLQ_decomp (gsl_matrix * A, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm)
{
const size_t N = A->size1;
const size_t M = A->size2;
if (tau->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
}
else if (p->size != N)
{
GSL_ERROR ("permutation size must be N", GSL_EBADLEN);
}
else if (norm->size != N)
{
GSL_ERROR ("norm size must be N", GSL_EBADLEN);
}
else
{
size_t i;
*signum = 1;
gsl_permutation_init (p); /* set to identity */
/* Compute column norms and store in workspace */
for (i = 0; i < N; i++)
{
gsl_vector_view c = gsl_matrix_row (A, i);
double x = gsl_blas_dnrm2 (&c.vector);
gsl_vector_set (norm, i, x);
}
for (i = 0; i < GSL_MIN (M, N); i++)
{
/* Bring the column of largest norm into the pivot position */
double max_norm = gsl_vector_get(norm, i);
size_t j, kmax = i;
for (j = i + 1; j < N; j++)
{
double x = gsl_vector_get (norm, j);
if (x > max_norm)
{
max_norm = x;
kmax = j;
}
}
if (kmax != i)
{
gsl_matrix_swap_rows (A, i, kmax);
gsl_permutation_swap (p, i, kmax);
gsl_vector_swap_elements(norm,i,kmax);
(*signum) = -(*signum);
}
/* Compute the Householder transformation to reduce the j-th
column of the matrix to a multiple of the j-th unit vector */
{
gsl_vector_view c_full = gsl_matrix_row (A, i);
gsl_vector_view c = gsl_vector_subvector (&c_full.vector,
i, M - i);
double tau_i = gsl_linalg_householder_transform (&c.vector);
gsl_vector_set (tau, i, tau_i);
/* Apply the transformation to the remaining columns */
if (i + 1 < N)
{
gsl_matrix_view m = gsl_matrix_submatrix (A, i +1, i, N - (i+1), M - i);
gsl_linalg_householder_mh (tau_i, &c.vector, &m.matrix);
}
}
/* Update the norms of the remaining columns too */
if (i + 1 < M)
{
for (j = i + 1; j < N; j++)
{
double x = gsl_vector_get (norm, j);
if (x > 0.0)
{
double y = 0;
double temp= gsl_matrix_get (A, j, i) / x;
if (fabs (temp) >= 1)
y = 0.0;
else
y = x * sqrt (1 - temp * temp);
/* recompute norm to prevent loss of accuracy */
if (fabs (y / x) < sqrt (20.0) * GSL_SQRT_DBL_EPSILON)
{
gsl_vector_view c_full = gsl_matrix_row (A, j);
gsl_vector_view c =
gsl_vector_subvector(&c_full.vector,
i+1, M - (i+1));
y = gsl_blas_dnrm2 (&c.vector);
}
gsl_vector_set (norm, j, y);
}
}
}
}
return GSL_SUCCESS;
}
}
int
gsl_linalg_complex_LU_decomp (gsl_matrix_complex * A, gsl_permutation * p, int *signum)
{
if (A->size1 != A->size2)
{
GSL_ERROR ("LU decomposition requires square matrix", GSL_ENOTSQR);
}
else if (p->size != A->size1)
{
GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN);
}
else
{
const size_t N = A->size1;
size_t i, j, k;
*signum = 1;
gsl_permutation_init (p);
for (j = 0; j < N - 1; j++)
{
/* Find maximum in the j-th column */
gsl_complex ajj = gsl_matrix_complex_get (A, j, j);
double max = gsl_complex_abs (ajj);
size_t i_pivot = j;
for (i = j + 1; i < N; i++)
{
gsl_complex aij = gsl_matrix_complex_get (A, i, j);
double ai = gsl_complex_abs (aij);
if (ai > max)
{
max = ai;
i_pivot = i;
}
}
if (i_pivot != j)
{
gsl_matrix_complex_swap_rows (A, j, i_pivot);
gsl_permutation_swap (p, j, i_pivot);
*signum = -(*signum);
}
ajj = gsl_matrix_complex_get (A, j, j);
if (!(GSL_REAL(ajj) == 0.0 && GSL_IMAG(ajj) == 0.0))
{
for (i = j + 1; i < N; i++)
{
gsl_complex aij_orig = gsl_matrix_complex_get (A, i, j);
gsl_complex aij = gsl_complex_div (aij_orig, ajj);
gsl_matrix_complex_set (A, i, j, aij);
for (k = j + 1; k < N; k++)
{
gsl_complex aik = gsl_matrix_complex_get (A, i, k);
gsl_complex ajk = gsl_matrix_complex_get (A, j, k);
/* aik = aik - aij * ajk */
gsl_complex aijajk = gsl_complex_mul (aij, ajk);
gsl_complex aik_new = gsl_complex_sub (aik, aijajk);
gsl_matrix_complex_set (A, i, k, aik_new);
}
}
}
}
return GSL_SUCCESS;
}
}
/** Sort an \ref apop_data set on an arbitrary sequence of columns.
The \c sort_order set is a one-row data set that should look like the data set being
sorted. The easiest way to generate it is to use \ref Apop_r to pull one row of the
table, then copy and fill it. For each column you want used in the sort, assign a ranking giving whether the column should be sorted first, second, .... Columns you don't want used in the sorting should be set to \c NAN. Ties are broken by the earlier element in the default order (see below).
E.g., to sort by the last column of a five-column matrix first, then the next-to-last column, then the next-to-next-to-last, then by the first text column, then by the second text column:
\code
apop_data *sort_order = apop_data_copy(Apop_r(data, 0));
sort_order->vector = NULL; //so it will be skipped.
Apop_data_fill(sort_order, NAN, NAN, 3, 2, 1);
apop_text_add(sort_order, 0, 0, "4");
apop_text_add(sort_order, 0, 1, "5");
apop_data_sort(data, sort_order);
\endcode
I use only comparisons, not the actual numeric values, so you can use any sequence of
numbers: (1, 2, 3) and (-1.32, 0, 27) work identically.
\li Strings are sorted case-insensitively, using \c strcasecmp. [exercise for the reader: modify the source to use Glib's locale-correct string sorting.]
\li The setup generates a lexicographic sort using the columns you specify. If you would like a different sort order, such as Euclidian distance to the origin, you can generate a new column expressing your preferred metric, and then sorting on that. See the example below.
\param data The data set to be sorted. If \c NULL, this function is a no-op that returns \c NULL.
\param sort_order A \ref apop_data set describing the order in which columns are used for sorting, as above. If \c NULL, then sort by the vector, then each matrix column, then text, then weights, then row names.
\param inplace If 'n', make a copy, else sort in place. (default: 'y').
\param asc If 'a', ascending; if 'd', descending. This is applied to all columns; column-by-column application is to do. (default: 'a').
\param col_order For internal use only. In your call, it should be \c NULL; the \ref designated syntax will takes care of it for you.
\return A pointer to the sorted data set. If <tt>inplace=='y'</tt> (the default), then this is the same as the input set.
A few examples:
\include "sort_example.c"
\li This function uses the \ref designated syntax for inputs.
*/
APOP_VAR_HEAD apop_data *apop_data_sort(apop_data *data, apop_data *sort_order, char asc, char inplace, double *col_order){
apop_data * apop_varad_var(data, NULL);
Apop_stopif(!data, return NULL, 1, "You gave me NULL data to sort. Returning NULL");
apop_data * apop_varad_var(sort_order, NULL);
char apop_varad_var(inplace, 'y');
char apop_varad_var(asc, 'a');
double * apop_varad_var(col_order, NULL);
APOP_VAR_ENDHEAD
if (!data) return NULL;
apop_data *out = inplace=='n' ? apop_data_copy(data) : data;
apop_data *xx = sort_order ? sort_order : out;
Get_vmsizes(xx); //firstcol, msize2
int cols_to_sort_ct = msize2 - firstcol +1 + !!(xx->weights) + xx->textsize[1] + !!xx->names->rowct;
double so[cols_to_sort_ct];
if (!col_order){
generate_sort_order(out, sort_order, cols_to_sort_ct, so);
col_order = so;
}
bool is_text = ((int)*col_order != *col_order);
bool is_name = (*col_order == 0.2);
gsl_vector_view c;
gsl_vector *cc = NULL;
if (!is_text && *col_order>=0){
c = gsl_matrix_column(out->matrix, *col_order);
cc = &c.vector;
}
gsl_vector *thiscol = cc ? cc
: (*col_order==-2) ? out->weights
: (*col_order==-1) ? out->vector
: NULL;
size_t height = thiscol ? thiscol->size
: is_name ? out->names->rowct
: *out->textsize;
gsl_permutation *p = gsl_permutation_alloc(height);
if (!is_text) gsl_sort_vector_index (p, thiscol);
else {
gsl_permutation_init(p);
d = out;
offset = is_name ? -1 : *col_order-0.5;
qsort(p->data, height, sizeof(size_t), compare_strings);
}
size_t *perm = p->data;
if (asc=='d' || asc=='D') //reverse the perm matrix.
for (size_t j=0; j< height/2; j++){
double t = perm[j];
perm[j] = perm[height-1-j];
perm[height-1-j] = t;
}
rearrange(out, height, perm);
gsl_permutation_free(p);
if (col_order[1] == -100) return out;
/*Second pass:
find blocks where all are of the same value.
After you pass a block of size > 1 row where all vals in this col are identical,
sort that block, using the rest of the sort order. */
int bottom=0;
if (!is_text){
double last_val = gsl_vector_get(thiscol, 0);
for (int i=1; i< height+1; i++){
double this_val=0;
if ((i==height || (this_val=gsl_vector_get(thiscol, i)) != last_val)
&& bottom != i-1){
apop_data_sort_base(Apop_rs(out, bottom, i-bottom), sort_order, 'a', 'y', col_order+1);
}
if (last_val != this_val) bottom = i;
last_val = this_val;
}
} else {
char *last_val = is_name ? out->names->row[0] : out->text[0][(int)(*col_order-0.5)];
for (int i=1; i< height+1; i++){
char *this_val = i==height ? NULL : is_name ? out->names->row[i] : out->text[i][(int)(*col_order-0.5)];
if ((i==height || strcasecmp(this_val, last_val))
&& bottom != i-1){
apop_data_sort_base(Apop_rs(out, bottom, i-bottom), sort_order, 'a', 'y', col_order+1);
}
if (this_val && strcmp(last_val, this_val)) bottom = i;
last_val = this_val;
}
}
return out;
}
void Permutation::Initialize(){
gsl_permutation_init(permutation);
}
void infomax(gsl_matrix *x_white, gsl_matrix *weights, gsl_matrix *S, int verbose){
/*Computes ICA infomax in whitened data
Decomposes x_white as x_white=AS
*Input
x_white: whitened data (Use PCAwhiten)
*Output
A : mixing matrix
S : source matrix
*/
// int verbose = 1; //true
size_t NCOMP = x_white->size1;
size_t NVOX = x_white->size2;
//getting permutation vector
const gsl_rng_type * T;
gsl_rng * r;
gsl_permutation * p = gsl_permutation_alloc (NVOX);
// gsl_rng_env_setup();
T = gsl_rng_default;
r = gsl_rng_alloc (T);
gsl_permutation_init (p);
gsl_matrix *old_weights = gsl_matrix_alloc(NCOMP,NCOMP);
gsl_matrix *bias = gsl_matrix_calloc(NCOMP, 1);
gsl_matrix *d_weights = gsl_matrix_calloc(NCOMP,NCOMP);
gsl_matrix *temp_change = gsl_matrix_alloc(NCOMP,NCOMP);
gsl_matrix *old_d_weights = gsl_matrix_calloc(NCOMP,NCOMP);
gsl_matrix *shuffled_x_white = gsl_matrix_calloc(NCOMP,x_white->size2);
gsl_matrix_memcpy(shuffled_x_white, x_white);
gsl_matrix_set_identity(weights);
gsl_matrix_set_identity(old_weights);
double lrate = 0.005/log((double)NCOMP);
double change=1;
double angle_delta =0;
size_t step = 1;
int error = 0;
while( (step < MAX_STEP) && (change > W_STOP)){
error = w_update(weights, x_white, bias,
shuffled_x_white, p, r, lrate);
if (error==1 || error==2){
// It blowed up! RESTART!
step = 1;
// change = 1;
error = 0;
lrate *= ANNEAL;
gsl_matrix_set_identity(weights);
gsl_matrix_set_identity(old_weights);
gsl_matrix_set_zero(d_weights);
gsl_matrix_set_zero(old_d_weights);
gsl_matrix_set_zero(bias);
if (lrate > MIN_LRATE){
printf("\nLowering learning rate to %g and starting again.\n",lrate);
}
else{
printf("\nMatrix may not be invertible");
}
}
else if (error==0){
gsl_matrix_memcpy(d_weights, weights);
gsl_matrix_sub(d_weights, old_weights);
change = matrix_norm(d_weights);
if (step > 2){
// Compute angle delta
gsl_matrix_memcpy(temp_change, d_weights);
gsl_matrix_mul_elements(temp_change, old_d_weights);
angle_delta = acos(matrix_sum(temp_change) / sqrt(matrix_norm(d_weights)*(matrix_norm(old_d_weights))));
angle_delta *= (180.0 / M_PI);
}
gsl_matrix_memcpy(old_weights, weights);
if (angle_delta > 60){
lrate *= ANNEAL;
gsl_matrix_memcpy(old_d_weights, d_weights);
} else if (step==1) {
gsl_matrix_memcpy(old_d_weights, d_weights);
}
if ((verbose && (step % 10)== 0) || change < W_STOP){
printf("\nStep %zu: Lrate %.1e, Wchange %.1e, Angle %.2f",
step, lrate, change, angle_delta);
}
step ++;
}
}
matrix_mmul(weights, x_white, S);
gsl_matrix_free(old_d_weights);
gsl_matrix_free(old_weights);
gsl_matrix_free(bias);
gsl_matrix_free(d_weights);
gsl_matrix_free(shuffled_x_white);
gsl_rng_free (r);
gsl_permutation_free (p);
}
int main(int argc, char **argv) {
gsl_rng *rng;
gsl_rng_env_setup();
const gsl_rng_type *rngType = gsl_rng_default;
rng = gsl_rng_alloc(rngType);
const size_t M = SIZE1;
const size_t N = SIZE2;
gsl_matrix *A = gsl_matrix_alloc(M, N);
int i = 0;
int j = 0;
int sigNum = 0;
for (i = 0; i < M; i++) {
for (j = 0; j < N; j++) {
gsl_matrix_set(A, i, j, gsl_ran_ugaussian(rng));
}
}
gsl_matrix *B = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(B, A);
gsl_matrix *C = gsl_matrix_alloc(M, N);
gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, A, B, 0.0, C);
gsl_matrix *D = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(D, C); // will be used in QTQ' decompostion
gsl_linalg_cholesky_decomp(C);
printf("%e\n", gsl_matrix_get(C, M/2, N/2));
gsl_matrix_free(B);
gsl_matrix *A1 = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(A1, A);
gsl_permutation *P = gsl_permutation_alloc(M); // will be used in
// other cases
gsl_permutation_init(P);
gsl_ran_shuffle (rng, P->data, M, sizeof(size_t));
gsl_linalg_LU_decomp(A1, P, &sigNum);
printf("%e\n", gsl_matrix_get(A1, M/2, N/2));
gsl_matrix *A2 = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(A2, A);
gsl_vector *tau = gsl_vector_alloc(GSL_MIN(M, N));
gsl_linalg_QR_decomp(A2, tau);
printf("%e\n", gsl_matrix_get(A2, M/2, N/2));
gsl_vector_free(tau);
gsl_matrix *A3 = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(A3, A);
gsl_matrix *svdV = gsl_matrix_alloc(N, N);
gsl_vector *svdS = gsl_vector_alloc(N);
gsl_vector *svdWorkspace = gsl_vector_alloc(N);
gsl_linalg_SV_decomp(A3, svdV, svdS, svdWorkspace);
printf("%e\n", gsl_vector_get(svdS, N/2));
gsl_vector *tau2 = gsl_vector_alloc(N - 1);
gsl_linalg_symmtd_decomp(D, tau2);
printf("%e\n", gsl_matrix_get(D, N/2, N/2));
return 0;
}
bool CEES_Node::Initialize(CStorageHead &storage, const gsl_rng *r)
{
// random permutation of 0, 1, ..., K-1
gsl_permutation *p = gsl_permutation_alloc(K);
gsl_permutation_init(p);
gsl_ran_shuffle(r, p->data, K, sizeof(int));
int binOffset;
if (next_level == NULL)
binOffset = this->BinID(0);
else
binOffset = next_level->BinID(0);
int index=0, bin_id;
while (index <K )
{
bin_id = binOffset+gsl_permutation_get(p, index);
if (storage.DrawSample(bin_id, r, x_current))
{
x_current.log_prob = -(x_current.GetWeight() > GetEnergy() ? x_current.GetWeight() : GetEnergy())/GetTemperature();
ring_index_current = GetRingIndex(x_current.GetWeight());
UpdateMinMaxEnergy(x_current.GetWeight());
gsl_permutation_free(p);
return true;
}
index ++;
}
gsl_permutation_free(p);
return false;
// Initialize using samples from the next level;
/*if (next_level == NULL)
{
for (int try_id = id; try_id >=0; try_id --)
{
int bin_id = this->BinID(try_id);
if (storage.DrawSample(bin_id, r, x_current))
{
x_current.log_prob = -(x_current.GetWeight() > GetEnergy() ? x_current.GetWeight() : GetEnergy())/GetTemperature();
ring_index_current = GetRingIndex(x_current.GetWeight());
UpdateMinMaxEnergy(x_current.GetWeight());
return true;
}
}
for (int try_id = id+1; try_id <K; try_id ++)
{
int bin_id = this->BinID(try_id);
if (storage.DrawSample(bin_id, r, x_current))
{
x_current.log_prob = -(x_current.GetWeight() > GetEnergy() ? x_current.GetWeight() : GetEnergy())/GetTemperature();
ring_index_current = GetRingIndex(x_current.GetWeight());
UpdateMinMaxEnergy(x_current.GetWeight());
return true;
}
}
}
else
{
// Try next levels' bins with the same or lower energies
for (int try_id = id; try_id >= 0; try_id --)
{
int bin_id_next_level = next_level->BinID(try_id);
if (storage.DrawSample(bin_id_next_level, r, x_current))
{
// x_current.weight will remain the same
// x_current.log_prob needs to be updated according to
// current level's H and T
x_current.log_prob = -(x_current.GetWeight() > GetEnergy() ? x_current.GetWeight() : GetEnergy())/GetTemperature();
ring_index_current = GetRingIndex(x_current.GetWeight());
UpdateMinMaxEnergy(x_current.GetWeight());
return true;
}
}
// If not successful, then try next level's bins with higher energies
for (int try_id = id+1; try_id <K; try_id ++)
{
int bin_id_next_level = next_level->BinID(try_id);
if (storage.DrawSample(bin_id_next_level, r, x_current))
{
// x_current.weight will remain the same
// x_current.log_prob needs to be updated according to
// current level's H and T
x_current.log_prob = -(x_current.GetWeight() > GetEnergy() ? x_current.GetWeight() : GetEnergy())/GetTemperature();
ring_index_current = GetRingIndex(x_current.GetWeight());
UpdateMinMaxEnergy(x_current.GetWeight());
return true;
}
}
}
return false; */
}
void gsl_matrix_hungarian(gsl_matrix* gm_C,gsl_matrix* gm_P,gsl_vector* gv_col_inc, gsl_permutation* gp_sol, int _bprev_init, gsl_matrix *gm_C_denied, bool bgreedy)
{
// mexPrintf("VV\n");
long dim, startdim, enddim, n1,n2;
double *C;
int i,j;
int **m;
double *z;
hungarian_problem_t p, *q;
int matrix_size;
double C_min=gsl_matrix_min(gm_C)-1;
n1 = gm_C->size1; /* first dimension of the cost matrix */
n2 = gm_C->size2; /* second dimension of the cost matrix */
C = gm_C->data;
//greedy solution
if (bgreedy)
{
int ind,ind1,ind2;
size_t *C_ind=new size_t[n1*n2];
gsl_heapsort_index(C_ind,C,n1*n2,sizeof(double),compare_doubles);
bool* bperm_fix_1=new bool[n1]; bool* bperm_fix_2=new bool[n2]; int inummatch=0;
for (i=0;i<n1;i++) {bperm_fix_1[i]=false;bperm_fix_2[i]=false;};
gsl_matrix_set_zero(gm_P);
for (long l=0;l<n1*n2;l++)
{
ind=C_ind[l];
ind1=floor(ind/n1);
ind2=ind%n2;
if (!bperm_fix_1[ind1] and !bperm_fix_2[ind2])
{
bperm_fix_1[ind1]=true; bperm_fix_2[ind2]=true;
gm_P->data[ind]=1;inummatch++;
};
if (inummatch==n1) break;
};
delete[] bperm_fix_1;delete[] bperm_fix_2;
//because C is a transpose matrix
gsl_matrix_transpose(gm_P);
return;
};
double C_max=((gsl_matrix_max(gm_C)-C_min>1)?(gsl_matrix_max(gm_C)-C_min):1)*(n1>n2?n1:n2);
m = (int**)calloc(n1,sizeof(int*));
// mexPrintf("C[2] = %f \n",C[2]);
for (i=0;i<n1;i++)
{
m[i] = (int*)calloc(n2,sizeof(int));
for (j=0;j<n2;j++)
m[i][j] = (int) (C[i+n1*j] - C_min);
// mexPrintf("m[%d][%d] = %f %f\n",i,j,m[i][j],C[i+n1*j] - C_min);
if (gm_C_denied!=NULL)
for (j=0;j<n2;j++){
if (j==30)
int dbg=1;
bool bden=(gm_C_denied->data[n2*i+j]<1e-10);
if (bden) m[i][j] =C_max;
else
int dbg=1;
};
};
//normalization: rows and columns
// mexPrintf("C[2] = %f \n",C[2]);
double dmin;
for (i=0;i<n1;i++)
{
dmin=m[i][0];
for (j=1;j<n2;j++)
dmin= (m[i][j]<dmin)? m[i][j]:dmin;
for (j=0;j<n2;j++)
m[i][j]-=dmin;
};
for (j=0;j<n2;j++)
{
dmin=m[0][j];
for (i=1;i<n1;i++)
dmin= (m[i][j]<dmin)? m[i][j]:dmin;
for (i=0;i<n1;i++)
m[i][j]-=dmin;
};
if ((_bprev_init) &&(gv_col_inc !=NULL))
{
//dual solution v substraction
for (j=0;j<n2;j++)
for (i=0;i<n1;i++)
m[i][j]-=gv_col_inc->data[j];
//permutation of m columns
int *mt = new int[n2];
for (i=0;i<n1;i++)
{
for (j=0;j<n2;j++) mt[j]=m[i][j];
for (j=0;j<n2;j++) m[i][j]=mt[gsl_permutation_get(gp_sol,j)];
};
delete[] mt;
};
/* initialize the hungarian_problem using the cost matrix*/
matrix_size = hungarian_init(&p, m , n1,n2, HUNGARIAN_MODE_MINIMIZE_COST) ;
/* solve the assignement problem */
hungarian_solve(&p);
q = &p;
//gsl_matrix* gm_P=gsl_matrix_alloc(n1,n2);
gsl_permutation* gp_sol_inv=gsl_permutation_alloc(n2);
if (gp_sol!=NULL)
gsl_permutation_inverse(gp_sol_inv,gp_sol);
else
gsl_permutation_init(gp_sol_inv);
for (i=0;i<n1;i++)
for (j=0;j<n2;j++)
gsl_matrix_set(gm_P,i,j,q->assignment[i][gp_sol_inv->data[j]]);
//initialization by the previous solution
if ((_bprev_init) &&(gv_col_inc !=NULL))
for (j=0;j<n2;j++)
gv_col_inc->data[j]=q->col_inc[gp_sol_inv->data[j]];
if ((_bprev_init) && (gp_sol!=NULL))
{
for (i=0;i<n1;i++)
for (j=0;j<n2;j++)
if (gsl_matrix_get(gm_P,i,j)==HUNGARIAN_ASSIGNED)
gp_sol->data[i]=j;
};
/* free used memory */
gsl_permutation_free(gp_sol_inv);
hungarian_free(&p);
for (i=0;i<n1;i++)
free(m[i]);
free(m);
/* for (int i=0;i<gm_C->size1;i++)
{
for (int j=0;j<gm_C->size1;j++)
{
mexPrintf("G[%d][%d] = %f %f \n",i,j,gsl_matrix_get(gm_P,i,j),gsl_matrix_get(gm_C,i,j));
}
}*/
// mexPrintf("AAA");
//return gm_P;
}
void generate_kmeans_centres(const double * X,const int dim_x,const int dim_n,const int dim_b,double * centres){
int i,N, iter,k,num_ix,num_empty_clusters;
int* ind_,*empty_clusters,*minDi,*ix;
size_t *sDi;
double * M, * D,*minDv,*X_ix,*X_ix_m,*X_ink,*sDv;
double dist_old, dist_new;
dist_old = 10000;
gsl_permutation *ind;
const gsl_rng_type *T;
gsl_rng * r;
// finish declaration
N = dim_n;
gsl_rng_env_setup();
T = gsl_rng_default;
r = gsl_rng_alloc(T);
gsl_rng_set(r,3);
ind = gsl_permutation_alloc(N);
gsl_permutation_init(ind);
gsl_ran_shuffle(r,ind->data,N,sizeof(size_t));
// gsl_permutation_fprintf(stdout,ind,"%u");
ind_ = malloc(dim_b*sizeof(int));
for (i=0;i<dim_b;i++){
ind_[i] = (int)(gsl_permutation_get(ind,i));
}
M = malloc(dim_x*dim_b*sizeof(double));
D = malloc(dim_b*dim_n*sizeof(double));
minDv = malloc(dim_n*sizeof(double));
minDi = malloc(dim_n*sizeof(int));
sDv = malloc(dim_n*sizeof(double));
sDi = malloc(dim_n*sizeof(int));
ix = malloc(dim_n*sizeof(int));
X_ix_m= malloc(dim_x*1*sizeof(double));
X_ink = malloc(dim_x*sizeof(double));
ccl_get_sub_mat_cols(X,dim_x,dim_n,ind_,dim_b,M);
empty_clusters = malloc(dim_b*sizeof(int));
num_empty_clusters = 0;
for (iter=0;iter<1001;iter++){
num_empty_clusters = 0;
ccl_mat_distance(M,dim_x,dim_b,X,dim_x,dim_n,D);
ccl_mat_min(D,dim_b,dim_n,1,minDv,minDi);
memcpy(sDv,minDv,dim_n*sizeof(double));
memset(empty_clusters,0,dim_b*sizeof(int));
for (k=0;k<dim_b;k++){
memset(ix,0,dim_n*sizeof(int));
num_ix = ccl_find_index_int(minDi,dim_n,1,k,ix);
// print_mat_i(ix,1,dim_n);
X_ix = malloc(dim_x*num_ix*sizeof(double));
if(num_ix!=0){// not empty
ccl_get_sub_mat_cols(X,dim_x,dim_n,ix,num_ix,X_ix);
ccl_mat_mean(X_ix,dim_x,num_ix,0,X_ix_m);
ccl_mat_set_col(M,dim_x,dim_b,k,X_ix_m);
}
else{
empty_clusters[num_empty_clusters] = k;
num_empty_clusters ++;
}
free(X_ix);
}
dist_new = ccl_vec_sum(minDv,dim_n);
if (num_empty_clusters == 0){
if(fabs(dist_old-dist_new)<1E-10) {
memcpy(centres,M,dim_x*dim_b*sizeof(double));
return;
}
}
else{
// print_mat_i(empty_clusters,1,num_empty_clusters);
gsl_sort_index(sDi,sDv,1,dim_n);
gsl_sort(sDv,1,dim_n);
for (k=0;k<num_empty_clusters;k++){
int ii = (int) sDi[dim_n-k-1];
//print_mat_d(X,dim_x,dim_n);
ccl_get_sub_mat_cols(X,dim_x,dim_n,&ii,1,X_ink);
ccl_mat_set_col(M,dim_x,dim_b,empty_clusters[k],X_ink);
}
}
dist_old = dist_new;
}
memcpy(centres,M,dim_x*dim_b*sizeof(double));
gsl_permutation_free(ind);
gsl_rng_free(r);
free(ind_);
free(empty_clusters);
free(minDi);
free(M);
free(minDv);
free(X_ink);
free(ix);
free(sDi);
free(sDv);
free(X_ix_m);
free(D);
}
/** *******************************************************************************************************************************************/
int generate_gaus_rv_inits(gsl_vector *myBeta,struct fnparams *gparams){
/** this is the SAME CODE as in the Gaussian case */
/** beta_hat= (X^T X)^{-1} X^T y **/
const datamatrix *designdata = ((struct fnparams *) gparams)->designdata;/** all design data inc Y and priors **/
const gsl_vector *Y = designdata->Y;/** response vector **/
const gsl_matrix *X = designdata->datamatrix_noRV ;/** design matrix - with one too few cols! **/
gsl_vector *vectmp1= gparams->vectmp1;/** numparams long*/
gsl_vector *vectmp2 = gparams->vectmp2;/** numparams long*/
gsl_matrix *mattmp2 = gparams->mattmp2;/** same dim as X*/
gsl_matrix *mattmp3 = gparams->mattmp3;/** p x p **/
gsl_matrix *mattmp4 = gparams->mattmp4;/** p x p **/
gsl_vector *vectmp1long = gparams->vectmp1long;/** scratch space **/
gsl_vector *vectmp2long = gparams->vectmp2long;/** scratch space **/
gsl_permutation *perm = gparams->perm;
unsigned int i;
int ss;
int haveError;
double variance=0.0;
double n=Y->size;/** no. observations **/
double m=X->size2;/** number of coefficients excluding tau-precision */
/*Rprintf("X: %d %d %d %d %d %d\n",X->size1,X->size2,mattmp2->size1,mattmp2->size2,mattmp3->size1,mattmp3->size2); */
gsl_matrix_memcpy(mattmp2,X);
gsl_blas_dgemm (CblasTrans, CblasNoTrans, /** mattmp3 is p x p matrix X^T X **/
1.0, X, mattmp2,
0.0, mattmp3);
gsl_permutation_init(perm);/** reset - might not be needed */
gsl_linalg_LU_decomp(mattmp3,perm,&ss);
gsl_set_error_handler_off();/**Turning off GSL Error handler as this may fail as mattmp3 may be singular */
haveError=gsl_linalg_LU_invert (mattmp3, perm, mattmp4);/** mattmp4 is now inv (X^T X) */
if(!haveError){/** no error */
/** copy Y into vectmp1long and +1 and take logs since poisson has log link - this is a fudge */
/*for(i=0;i<vectmp1long->size;i++){gsl_vector_set(vectmp1long,i,log(gsl_vector_get(Y,i)+DBL_MIN)/(log(1-gsl_vector_get(Y,i)+DBL_MIN)));} */
/*for(i=0;i<vectmp1long->size;i++){gsl_vector_set(vectmp1long,i,log(gsl_vector_get(Y,i)+1)/(log(1-gsl_vector_get(Y,i)+1)));} */
gsl_blas_dgemv (CblasTrans, 1.0, X, Y, 0.0, vectmp1); /** X^T Y */
gsl_blas_dgemv (CblasNoTrans, 1.0, mattmp4, vectmp1, 0.0, vectmp2);
for(i=0;i<myBeta->size-2;i++){gsl_vector_set(myBeta,i,gsl_vector_get(vectmp2,i));} /** size myBeta->size-2 as last two entries are precisions **/
} else {/** singular to set initial values all to zero **/
Rprintf("caught gsl error - singular matrix in initial guess estimates\n");
for(i=0;i<myBeta->size;i++){gsl_vector_set(myBeta,i,0.01);}}
gsl_set_error_handler (NULL);/** restore the error handler*/
/*Rprintf("inits\n");for(i=0;i<myBeta->size;i++){Rprintf("%10.15e ",gsl_vector_get(myBeta,i));} Rprintf("\n");*//** set to Least squares estimate */
/** now for variance estimate */
/** first get y_hat estimate */
gsl_blas_dgemv (CblasNoTrans, 1.0, X, vectmp2, 0.0, vectmp1long); /** vectmp1 is y_hat */
/*for(i=0;i<vectmp1long->size;i++){Rprintf("y_hat=%f\n",gsl_vector_get(vectmp1long,i));}*/
/*error("");*/
gsl_vector_scale(vectmp1long,-1.0);/** - y_hat */
gsl_vector_add(vectmp1long,Y);/** now have Y-y_hat (or -y_hat + Y) */
/*for(i=0;i<vectmp1long->size;i++){gsl_vector_set(vectmp1long,i,fabs(gsl_vector_get(vectmp1long,i)));}
for(i=0;i<vectmp1long->size;i++){Rprintf("y_hat=%f\n",gsl_vector_get(vectmp1long,i));}
for(i=0;i<vectmp1long->size;i++){gsl_vector_set(vectmp1long,i,log(gsl_vector_get(vectmp1long,i))/log(1-gsl_vector_get(vectmp1long,i)));}*/ /** errors on logit scale **/
/*gsl_vector_set_all(vectmp2long,1);*/
gsl_vector_memcpy(vectmp2long,vectmp1long);
gsl_blas_ddot (vectmp1long, vectmp2long, &variance);/** got sum((Y-Y_hat)^2) */
variance=variance/(n-m);/** unbiased estimator using denominator n-#term in regression equation **/
/* Rprintf("variance estimator=%f precision=%f\n",variance,1/variance);*/
/* variance=0.086;*/
/*variance=exp(gsl_vector_get(myBeta,0))/(1+exp(gsl_vector_get(myBeta,0)));*/
/** variance here is for plain glm - just split this 50/50 between residual error and group level variance **/
gsl_vector_set(myBeta,myBeta->size-2,1.0/(0.5*variance));/** - estimate for rv precision **/
gsl_vector_set(myBeta,myBeta->size-1,1.0/(0.5*variance));/** - estimate for residual precision **/
/*gsl_vector_set(myBeta,myBeta->size-1,1.0/variance); */
/*gsl_vector_set(myBeta,0,0.9 );gsl_vector_set(myBeta,1,0.9);gsl_vector_set(myBeta,2,1.5);*/
#ifdef junk
Rprintf("------------ TEMP: Using Fixed initial values from LME4----------------\n");
gsl_vector_set(myBeta,0,0.062044233);/** intercept */
gsl_vector_set(myBeta,1,-0.1229382094322);/** slope g2 */
gsl_vector_set(myBeta,2,1.0/0.1570366587829);/** group level precision */
gsl_vector_set(myBeta,3,1.0/0.8628565204966);/** residual precision */
#endif
/*Rprintf("inits\n");for(i=0;i<myBeta->size;i++){Rprintf("%10.15e ",gsl_vector_get(myBeta,i));} Rprintf("\n");*//** set to Least squares estimate */
return GSL_SUCCESS;
}
int rgb_permutations(Test **test,int irun)
{
uint i,j,k,permindex=0,t;
Vtest vtest;
double *testv;
size_t ps[4096];
gsl_permutation** lookup;
MYDEBUG(D_RGB_PERMUTATIONS){
printf("#==================================================================\n");
printf("# rgb_permutations: Debug with %u\n",D_RGB_PERMUTATIONS);
}
/*
* Number of permutations. Note that the minimum ntuple value for a
* valid test is 2. If ntuple is less than 2, we choose the default
* test size as 5 (like operm5).
*/
if(ntuple<2){
test[0]->ntuple = 5;
} else {
test[0]->ntuple = ntuple;
}
k = test[0]->ntuple;
nperms = gsl_sf_fact(k);
/*
* A vector to accumulate rands in some sort order
*/
testv = (double *)malloc(k*sizeof(double));
MYDEBUG(D_RGB_PERMUTATIONS){
printf("# rgb_permutations: There are %u permutations of length k = %u\n",nperms,k);
}
/*
* Create a test, initialize it.
*/
Vtest_create(&vtest,nperms);
vtest.cutoff = 5.0;
for(i=0;i<nperms;i++){
vtest.x[i] = 0.0;
vtest.y[i] = (double) test[0]->tsamples/nperms;
}
MYDEBUG(D_RGB_PERMUTATIONS){
printf("# rgb_permutations: Allocating permutation lookup table.\n");
}
lookup = (gsl_permutation**) malloc(nperms*sizeof(gsl_permutation*));
for(i=0;i<nperms;i++){
lookup[i] = gsl_permutation_alloc(k);
}
for(i=0;i<nperms;i++){
if(i == 0){
gsl_permutation_init(lookup[i]);
} else {
gsl_permutation_memcpy(lookup[i],lookup[i-1]);
gsl_permutation_next(lookup[i]);
}
}
MYDEBUG(D_RGB_PERMUTATIONS){
for(i=0;i<nperms;i++){
printf("# rgb_permutations: %u => ",i);
gsl_permutation_fprintf(stdout,lookup[i]," %u");
printf("\n");
}
}
/*
* We count the order permutations in a long string of samples of
* rgb_permutation_k non-overlapping rands. This is done by:
* a) Filling testv[] with rgb_permutation_k rands.
* b) Using gsl_sort_index to generate the permutation index.
* c) Incrementing a counter for that index (a-c done tsamples times)
* d) Doing a straight chisq on the counter vector with nperms-1 DOF
*
* This test should be done with tsamples > 30*nperms, easily met for
* reasonable rgb_permutation_k
*/
for(t=0;t<test[0]->tsamples;t++){
/*
* To sort into a perm, test vector needs to be double.
*/
for(i=0;i<k;i++) {
testv[i] = (double) gsl_rng_get(rng);
MYDEBUG(D_RGB_PERMUTATIONS){
printf("# rgb_permutations: testv[%u] = %u\n",i,(uint) testv[i]);
}
}
gsl_sort_index(ps,testv,1,k);
MYDEBUG(D_RGB_PERMUTATIONS){
for(i=0;i<k;i++) {
printf("# rgb_permutations: ps[%u] = %lu\n",i,ps[i]);
}
}
for(i=0;i<nperms;i++){
if(memcmp(ps,lookup[i]->data,k*sizeof(size_t))==0){
permindex = i;
MYDEBUG(D_RGB_PERMUTATIONS){
printf("# Found permutation: ");
gsl_permutation_fprintf(stdout,lookup[i]," %u");
printf(" = %u\n",i);
}
break;
}
}
vtest.x[permindex]++;
MYDEBUG(D_RGB_PERMUTATIONS){
printf("# rgb_permutations: Augmenting vtest.x[%u] = %f\n",permindex,vtest.x[permindex]);
}
}
