/* calculation of graph diameter */
void diameter_cal (dub * u)
{
int k = 1, // maximum length in the graph
i, j, // loop indices
cont = 0; // continue flag for the 'do-while' loop
gsl_matrix * M = gsl_matrix_alloc (u->N, u->N),
* R = gsl_matrix_alloc (u->N, u->N);
/* we copy the matrix */
gsl_matrix_memcpy (M, u->A);
do
{
/* we scan for the zeroes, we only check the upper triangle, without diagonal */
for (i = 0; i <= u->N - 1; i++)
{
cont = 0;
for (j = i+1; j <= u->N - 1; j++)
{
if (!gsl_matrix_get(M, i, j))
{
cont = 1;
break;
}
}
if (cont) break;
}
if (cont)
{
gsl_blas_dsymm (CblasRight, CblasLower, 1.0, M, u->A, 0.0, R);
gsl_matrix_memcpy (M, R);
k++;
}
else break;
} while (cont && k <= u->N-1);
gsl_matrix_free (M);
gsl_matrix_free (R);
u->diam = k;
}
int NBinGlm::nbinfit(gsl_matrix *Y, gsl_matrix *X, gsl_matrix *O, gsl_matrix *B)
{
gsl_set_error_handler_off();
initialGlm(Y, X, O, B);
gsl_rng *rnd=gsl_rng_alloc(gsl_rng_mt19937);
unsigned int i, j; //, isConv;
double yij, mij, vij, hii, uij, wij, wei;
double th, tol, dev_th_b_old;
int status;
// gsl_vector_view b0j, m0j, e0j, v0j;
gsl_matrix *WX = gsl_matrix_alloc(nRows, nParams);
gsl_matrix *TMP = gsl_matrix_alloc(nRows, nParams);
gsl_matrix *XwX = gsl_matrix_alloc(nParams, nParams);
gsl_vector_view Xwi, Xi, vj, dj, hj;
for (j=0; j<nVars; j++) {
betaEst(j, maxiter, &tol, maxtol); //poisson
// Get initial theta estimates
iterconv[j]=0.0;
if (mmRef->estiMethod==CHI2) {
th = getDisper(j, 1.0);
while ( iterconv[j]<maxiter ) {
//printf("th=%.2f, iterconv[%d]=%d\n", th, j, iterconv[j]);
iterconv[j]++;
dev_th_b_old = dev[j];
betaEst(j, 1.0, &tol, th); // 1-step beta
th = getDisper(j, th)/th;
tol = ABS((dev[j]-dev_th_b_old)/(ABS(dev[j])+0.1));
if (tol<eps) break;
} }
else if (mmRef->estiMethod==NEWTON) {
th = thetaML(0.0, j, maxiter);
while ( iterconv[j]<maxiter ) {
iterconv[j]++;
dev_th_b_old = dev[j];
th = thetaML(th, j, maxiter2);
betaEst(j, maxiter2, &tol, th);
tol=ABS((dev[j]-dev_th_b_old)/(ABS(dev[j])+0.1));
if (tol<eps) break;
} }
else {
th = getfAfAdash(0.0, j, maxiter);
/* lm=0;
for (i=0; i<nRows; i++) {
yij = gsl_matrix_get(Y, i, j);
mij = gsl_matrix_get(Mu, i, j);
lm = lm + llfunc( yij, mij, th);
} */
while ( iterconv[j]<maxiter ) {
iterconv[j]++;
dev_th_b_old = dev[j];
betaEst(j, maxiter2, &tol, th);
th = getfAfAdash(th, j, 1.0);
tol=ABS((dev[j]-dev_th_b_old)/(ABS(dev[j])+0.1));
if (tol<eps) break;
}
}
if ((iterconv[j]==maxiter)&(mmRef->warning==TRUE))
printf("Warning: reached maximum itrations - negative binomial may NOT converge in the %d-th variable (dev=%.4f, err=%.4f, theta=%.4f)!\n", j, dev[j], tol, th);
// other properties based on mu and phi
theta[j] = th;
gsl_matrix_memcpy(WX, Xref);
ll[j]=0;
for (i=0; i<nRows; i++) {
yij = gsl_matrix_get(Y, i, j);
mij = gsl_matrix_get(Mu, i, j);
vij = varfunc( mij, th);
gsl_matrix_set(Var, i, j, vij);
wij = sqrt(weifunc(mij, th));
gsl_matrix_set(wHalf, i, j, wij);
gsl_matrix_set(Res, i, j, (yij-mij)/sqrt(vij));
ll[j] = ll[j] + llfunc( yij, mij, th);
// get PIT residuals for discrete data
wei = gsl_rng_uniform_pos (rnd); // wei ~ U(0, 1)
uij=wei*cdf(yij, mij, th);
if (yij>0) uij=uij+(1-wei)*cdf((yij-1),mij,th);
gsl_matrix_set(PitRes, i, j, uij);
// W^1/2 X
Xwi = gsl_matrix_row (WX, i);
gsl_vector_scale(&Xwi.vector, wij);
}
aic[j]=-ll[j]+2*(nParams+1);
// X^T * W * X
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 calculating pit-residuals. 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_linalg_cholesky_invert (XwX); // (X'WX)^-1
// Calc varBeta
vj = gsl_matrix_column (varBeta, j);
dj = gsl_matrix_diagonal (XwX);
gsl_vector_memcpy (&vj.vector, &dj.vector);
// hii is diagonal element of H=X*(X'WX)^-1*X'*W
hj = gsl_matrix_column (sqrt1_Hii, j);
gsl_blas_dsymm(CblasRight,CblasLower,1.0,XwX,Xref,0.0,TMP); // X*(X'WX)^-1
for (i=0; i<nRows; i++) {
Xwi=gsl_matrix_row(TMP, i);
Xi=gsl_matrix_row(Xref, i);
wij=gsl_matrix_get(wHalf, i, j);
gsl_blas_ddot(&Xwi.vector, &Xi.vector, &hii);
gsl_vector_set(&hj.vector, i, MAX(mintol, sqrt(MAX(0, 1-wij*wij*hii))));
//printf("hii=%.4f, wij=%.4f, sqrt(1-wij*wij*hii)=%.4f\n", hii, wij, sqrt(1-wij*wij*hii));
}
} // end nVar for j loop
// gsl_matrix_div_elements (Res, sqrt1_Hii);
// subtractMean(Res);
gsl_matrix_free(XwX);
gsl_matrix_free(WX);
gsl_matrix_free(TMP);
gsl_rng_free(rnd);
return SUCCESS;
}
int PoissonGlm::EstIRLS(gsl_matrix *Y, gsl_matrix *X, gsl_matrix *O, gsl_matrix *B, double *a)
{
initialGlm(Y, X, O, B);
gsl_set_error_handler_off();
gsl_rng *rnd=gsl_rng_alloc(gsl_rng_mt19937);
unsigned int i, j;
int status;
double yij, mij, vij, wij, tol, hii, uij, wei;
gsl_vector_view Xwi, Xi, vj, hj, dj;
gsl_matrix *WX = gsl_matrix_alloc(nRows, nParams);
gsl_matrix *TMP = gsl_matrix_alloc(nRows, nParams);
gsl_matrix *XwX = gsl_matrix_alloc(nParams, nParams);
for (j=0; j<nVars; j++) {
if ( a!=NULL ) theta[j]=a[j];
// estimate mu and beta
iterconv[j] = betaEst(j, maxiter, &tol, theta[j]);
if ((mmRef->warning==TRUE)&(iterconv[j]==maxiter))
printf("Warning: EstIRLS reached max iterations, may not converge in the %d-th variable (dev=%.4f, err=%.4f)!\n", j, dev[j], tol);
gsl_matrix_memcpy (WX, X);
for (i=0; i<nRows; i++) {
mij = gsl_matrix_get(Mu, i, j);
// get variance
vij = varfunc( mij, theta[j] );
gsl_matrix_set(Var, i, j, vij);
// get weight
wij = sqrt(weifunc(mij, theta[j]));
gsl_matrix_set(wHalf, i, j, wij);
// get (Pearson) residuals
yij = gsl_matrix_get(Y, i, j);
gsl_matrix_set(Res, i, j, (yij-mij)/sqrt(vij));
// get PIT residuals for discrete data
wei = gsl_rng_uniform_pos (rnd); // wei ~ U(0, 1)
uij = wei*cdf(yij, mij, theta[j]);
if (yij>0) uij=uij+(1-wei)*cdf((yij-1),mij,theta[j]);
gsl_matrix_set(PitRes, i, j, uij);
// get elementry log-likelihood
ll[j] = ll[j] + llfunc( yij, mij, theta[j]);
// W^1/2 X
Xwi = gsl_matrix_row (WX, i);
gsl_vector_scale(&Xwi.vector, wij);
}
aic[j]=-ll[j]+2*(nParams);
// X^T * W * X
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 calculating pit-residuals. 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_linalg_cholesky_invert (XwX);
// Calc varBeta
dj = gsl_matrix_diagonal (XwX);
vj = gsl_matrix_column (varBeta, j);
gsl_vector_memcpy (&vj.vector, &dj.vector);
// hii is diagonal element of H=X*(X'WX)^-1*X'*W
hj = gsl_matrix_column (sqrt1_Hii, j);
gsl_blas_dsymm(CblasRight,CblasLower,1.0,XwX,Xref,0.0,TMP); // X*(X'WX)^-1
for (i=0; i<nRows; i++) {
Xwi=gsl_matrix_row(TMP, i);
Xi=gsl_matrix_row(Xref, i);
wij=gsl_matrix_get(wHalf, i, j);
gsl_blas_ddot(&Xwi.vector, &Xi.vector, &hii);
gsl_vector_set(&hj.vector, i, MAX(mintol, sqrt(MAX(0, 1-wij*wij*hii))));
}
}
// standardize perason residuals by rp/sqrt(1-hii)
// gsl_matrix_div_elements (Res, sqrt1_Hii);
// subtractMean(Res); // have mean subtracted
gsl_matrix_free(XwX);
gsl_matrix_free(WX);
gsl_matrix_free(TMP);
gsl_rng_free(rnd);
return SUCCESS;
}
/**
* C++ version of gsl_blas_dsymm().
* @param Side Side to apply operation to
* @param Uplo Upper or lower triangular
* @param alpha A constant
* @param A A matrix
* @param B Another matrix
* @param beta Another constant
* @param C Another matrix
* @return Error code on failure
*/
int dsymm( CBLAS_SIDE_t Side, CBLAS_UPLO_t Uplo, double alpha,
matrix const& A, matrix const& B, double beta, matrix& C ){
return gsl_blas_dsymm( Side, Uplo, alpha, A.get(), B.get(), beta, C.get() ); }
int MatMulSym(Matrix &C, Matrix &A, Matrix &B) {
return gsl_blas_dsymm( CblasLeft, CblasUpper, 1.0, A.Ma(), B.Ma(), 0.0, C.Ma());
}
static int MismatchTest(
LatticeTiling *tiling,
gsl_matrix *metric,
const double max_mismatch,
const UINT8 total_ref,
const double mism_hist_ref[MISM_HIST_BINS]
)
{
const size_t n = XLALTotalLatticeTilingDimensions(tiling);
// Create lattice tiling iterator and locator
LatticeTilingIterator *itr = XLALCreateLatticeTilingIterator(tiling, n);
XLAL_CHECK(itr != NULL, XLAL_EFUNC);
LatticeTilingLocator *loc = XLALCreateLatticeTilingLocator(tiling);
XLAL_CHECK(loc != NULL, XLAL_EFUNC);
// Count number of points
const UINT8 total = XLALTotalLatticeTilingPoints(itr);
printf("Number of lattice points: %" LAL_UINT8_FORMAT "\n", total);
XLAL_CHECK(imaxabs(total - total_ref) <= 1, XLAL_EFUNC, "ERROR: |total - total_ref| = |%" LAL_UINT8_FORMAT " - %" LAL_UINT8_FORMAT "| > 1", total, total_ref);
// Get all points
gsl_matrix *GAMAT(points, n, total);
XLAL_CHECK(XLALNextLatticeTilingPoints(itr, &points) == (int)total, XLAL_EFUNC);
XLAL_CHECK(XLALNextLatticeTilingPoint(itr, NULL) == 0, XLAL_EFUNC);
// Initialise mismatch histogram counts
double mism_hist[MISM_HIST_BINS] = {0};
double mism_hist_total = 0, mism_hist_out_of_range = 0;
// Perform 10 injections for every template
{
gsl_matrix *GAMAT(injections, 3, total);
gsl_matrix *GAMAT(nearest, 3, total);
gsl_matrix *GAMAT(temp, 3, total);
RandomParams *rng = XLALCreateRandomParams(total);
XLAL_CHECK(rng != NULL, XLAL_EFUNC);
for (size_t i = 0; i < 10; ++i) {
// Generate random injection points
XLAL_CHECK(XLALRandomLatticeTilingPoints(tiling, 0.0, rng, injections) == XLAL_SUCCESS, XLAL_EFUNC);
// Find nearest lattice template points
XLAL_CHECK(XLALNearestLatticeTilingPoints(loc, injections, &nearest, NULL) == XLAL_SUCCESS, XLAL_EFUNC);
// Compute mismatch between injections
gsl_matrix_sub(nearest, injections);
gsl_blas_dsymm(CblasLeft, CblasUpper, 1.0, metric, nearest, 0.0, temp);
for (size_t j = 0; j < temp->size2; ++j) {
gsl_vector_view temp_j = gsl_matrix_column(temp, j);
gsl_vector_view nearest_j = gsl_matrix_column(nearest, j);
double mismatch = 0.0;
gsl_blas_ddot(&nearest_j.vector, &temp_j.vector, &mismatch);
mismatch /= max_mismatch;
// Increment mismatch histogram counts
++mism_hist_total;
if (mismatch < 0.0 || mismatch > 1.0) {
++mism_hist_out_of_range;
} else {
++mism_hist[lround(floor(mismatch * MISM_HIST_BINS))];
}
}
}
// Cleanup
GFMAT(injections, nearest, temp);
XLALDestroyRandomParams(rng);
}
// Normalise histogram
for (size_t i = 0; i < MISM_HIST_BINS; ++i) {
mism_hist[i] *= MISM_HIST_BINS / mism_hist_total;
}
// Print mismatch histogram and its reference
printf("Mismatch histogram: ");
for (size_t i = 0; i < MISM_HIST_BINS; ++i) {
printf(" %0.3f", mism_hist[i]);
}
printf("\n");
printf("Reference histogram:");
for (size_t i = 0; i < MISM_HIST_BINS; ++i) {
printf(" %0.3f", mism_hist_ref[i]);
}
printf("\n");
// Determine error between mismatch histogram and its reference
double mism_hist_error = 0.0;
for (size_t i = 0; i < MISM_HIST_BINS; ++i) {
mism_hist_error += fabs(mism_hist[i] - mism_hist_ref[i]);
}
mism_hist_error /= MISM_HIST_BINS;
printf("Mismatch histogram error: %0.3e\n", mism_hist_error);
const double mism_hist_error_tol = 5e-2;
if (mism_hist_error >= mism_hist_error_tol) {
XLAL_ERROR(XLAL_EFAILED, "ERROR: mismatch histogram error exceeds %0.3e\n", mism_hist_error_tol);
}
// Check fraction of injections out of histogram range
const double mism_out_of_range = mism_hist_out_of_range / mism_hist_total;
printf("Fraction of points out of histogram range: %0.3e\n", mism_out_of_range);
const double mism_out_of_range_tol = 2e-3;
if (mism_out_of_range > mism_out_of_range_tol) {
XLAL_ERROR(XLAL_EFAILED, "ERROR: fraction of points out of histogram range exceeds %0.3e\n", mism_out_of_range_tol);
}
// Perform 10 injections outside parameter space
{
gsl_matrix *GAMAT(injections, 3, 10);
gsl_matrix *GAMAT(nearest, n, total);
RandomParams *rng = XLALCreateRandomParams(total);
XLAL_CHECK(rng != NULL, XLAL_EFUNC);
// Generate random injection points outside parameter space
XLAL_CHECK(XLALRandomLatticeTilingPoints(tiling, 5.0, rng, injections) == XLAL_SUCCESS, XLAL_EFUNC);
// Find nearest lattice template points
XLAL_CHECK(XLALNearestLatticeTilingPoints(loc, injections, &nearest, NULL) == XLAL_SUCCESS, XLAL_EFUNC);
// Cleanup
GFMAT(injections, nearest);
XLALDestroyRandomParams(rng);
}
// Cleanup
XLALDestroyLatticeTiling(tiling);
XLALDestroyLatticeTilingIterator(itr);
XLALDestroyLatticeTilingLocator(loc);
GFMAT(metric, points);
LALCheckMemoryLeaks();
printf("\n");
fflush(stdout);
return XLAL_SUCCESS;
}
static VALUE rb_gsl_blas_dsymm(int argc, VALUE *argv, VALUE obj)
{
gsl_matrix *A = NULL, *B = NULL, *C = NULL;
double alpha, beta;
CBLAS_SIDE_t Side;
CBLAS_UPLO_t Uplo;
int flag = 0;
switch (argc) {
case 2:
CHECK_MATRIX(argv[0]);
CHECK_MATRIX(argv[1]);
Data_Get_Struct(argv[0], gsl_matrix, A);
Data_Get_Struct(argv[1], gsl_matrix, B);
C = gsl_matrix_calloc(A->size1, B->size2);
alpha = 1.0;
beta = 0.0;
Side = CblasLeft; Uplo = CblasUpper;
flag = 1;
break;
case 5:
CHECK_FIXNUM(argv[0]);
CHECK_FIXNUM(argv[1]);
Need_Float(argv[2]);
CHECK_MATRIX(argv[3]);
CHECK_MATRIX(argv[4]);
Side = FIX2INT(argv[0]);
Uplo = FIX2INT(argv[1]);
alpha = NUM2DBL(argv[2]);
Data_Get_Struct(argv[3], gsl_matrix, A);
Data_Get_Struct(argv[4], gsl_matrix, B);
C = gsl_matrix_calloc(A->size1, B->size2);
beta = 0.0;
flag = 1;
break;
case 6:
CHECK_FIXNUM(argv[0]);
CHECK_FIXNUM(argv[1]);
Need_Float(argv[2]);
CHECK_MATRIX(argv[3]);
CHECK_MATRIX(argv[4]);
Need_Float(argv[5]);
CHECK_MATRIX(argv[6]);
Side = FIX2INT(argv[0]);
Uplo = FIX2INT(argv[1]);
alpha = NUM2DBL(argv[2]);
Data_Get_Struct(argv[3], gsl_matrix, A);
Data_Get_Struct(argv[4], gsl_matrix, B);
beta = NUM2DBL(argv[5]);
C = gsl_matrix_calloc(A->size1, B->size2);
flag = 1;
break;
case 7:
CHECK_FIXNUM(argv[0]);
CHECK_FIXNUM(argv[1]);
Need_Float(argv[2]);
CHECK_MATRIX(argv[3]);
CHECK_MATRIX(argv[4]);
Need_Float(argv[5]);
CHECK_MATRIX(argv[6]);
Side = FIX2INT(argv[0]);
Uplo = FIX2INT(argv[1]);
alpha = NUM2DBL(argv[2]);
Data_Get_Struct(argv[3], gsl_matrix, A);
Data_Get_Struct(argv[4], gsl_matrix, B);
beta = NUM2DBL(argv[5]);
Data_Get_Struct(argv[6], gsl_matrix, C);
break;
default:
rb_raise(rb_eArgError, "wrong number of arguments (%d for 2 or 7)", argc);
break;
}
gsl_blas_dsymm(Side, Uplo, alpha, A, B, beta, C);
if (flag == 1) return Data_Wrap_Struct(cgsl_matrix, 0, gsl_matrix_free, C);
else return argv[6];
}
static void
post_sweep_computations (linreg *l, gsl_matrix *sw)
{
gsl_matrix *xm;
gsl_matrix_view xtx;
gsl_matrix_view xmxtx;
double m;
double tmp;
size_t i;
size_t j;
int rc;
assert (sw != NULL);
assert (l != NULL);
l->sse = gsl_matrix_get (sw, l->n_indeps, l->n_indeps);
l->mse = l->sse / l->dfe;
/*
Get the intercept.
*/
m = l->depvar_mean;
for (i = 0; i < l->n_indeps; i++)
{
tmp = gsl_matrix_get (sw, i, l->n_indeps);
l->coeff[i] = tmp;
m -= tmp * linreg_get_indep_variable_mean (l, i);
}
/*
Get the covariance matrix of the parameter estimates.
Only the upper triangle is necessary.
*/
/*
The loops below do not compute the entries related
to the estimated intercept.
*/
for (i = 0; i < l->n_indeps; i++)
for (j = i; j < l->n_indeps; j++)
{
tmp = -1.0 * l->mse * gsl_matrix_get (sw, i, j);
gsl_matrix_set (l->cov, i + 1, j + 1, tmp);
}
/*
Get the covariances related to the intercept.
*/
xtx = gsl_matrix_submatrix (sw, 0, 0, l->n_indeps, l->n_indeps);
xmxtx = gsl_matrix_submatrix (l->cov, 0, 1, 1, l->n_indeps);
xm = gsl_matrix_calloc (1, l->n_indeps);
for (i = 0; i < xm->size2; i++)
{
gsl_matrix_set (xm, 0, i,
linreg_get_indep_variable_mean (l, i));
}
rc = gsl_blas_dsymm (CblasRight, CblasUpper, l->mse,
&xtx.matrix, xm, 0.0, &xmxtx.matrix);
gsl_matrix_free (xm);
if (rc == GSL_SUCCESS)
{
tmp = l->mse / l->n_obs;
for (i = 1; i < 1 + l->n_indeps; i++)
{
tmp -= gsl_matrix_get (l->cov, 0, i)
* linreg_get_indep_variable_mean (l, i - 1);
}
gsl_matrix_set (l->cov, 0, 0, tmp);
l->intercept = m;
}
else
{
fprintf (stderr, "%s:%d:gsl_blas_dsymm: %s\n",
__FILE__, __LINE__, gsl_strerror (rc));
exit (rc);
}
}
