static int
exp1_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(exp1_J, exp1_N, exp1_P);
double x1 = gsl_vector_get(x, 0);
double x2 = gsl_vector_get(x, 1);
double x3 = gsl_vector_get(x, 2);
double x4 = gsl_vector_get(x, 3);
size_t i;
for (i = 0; i < exp1_N; ++i)
{
double ti = 0.02*(i + 1.0);
double term1 = exp(x1*ti);
double term2 = exp(x2*ti);
gsl_matrix_set(&J.matrix, i, 0, -x3*ti*term1);
gsl_matrix_set(&J.matrix, i, 1, -x4*ti*term2);
gsl_matrix_set(&J.matrix, i, 2, -term1);
gsl_matrix_set(&J.matrix, i, 3, -term2);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static int
vardim_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(vardim_J, vardim_N, vardim_P);
size_t i;
double sum = 0.0;
gsl_matrix_view m = gsl_matrix_submatrix(&J.matrix, 0, 0, vardim_P, vardim_P);
gsl_matrix_set_identity(&m.matrix);
for (i = 0; i < vardim_P; ++i)
{
double xi = gsl_vector_get(x, i);
sum += (i + 1.0) * (xi - 1.0);
}
for (i = 0; i < vardim_P; ++i)
{
gsl_matrix_set(&J.matrix, vardim_P, i, i + 1.0);
gsl_matrix_set(&J.matrix, vardim_P + 1, i, 2*(i + 1.0)*sum);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static int
boxbod_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(boxbod_J, boxbod_N, boxbod_P);
double b[boxbod_P];
size_t i;
for (i = 0; i < boxbod_P; i++)
{
b[i] = gsl_vector_get(x, i);
}
for (i = 0; i < boxbod_N; i++)
{
double xi = boxbod_X[i];
double term = exp(-b[1] * xi);
gsl_matrix_set (&J.matrix, i, 0, 1.0 - term);
gsl_matrix_set (&J.matrix, i, 1, b[0] * term * xi);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static int
wood_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(wood_J, wood_N, wood_P);
double x1 = gsl_vector_get(x, 0);
double x3 = gsl_vector_get(x, 2);
double s90 = sqrt(90.0);
double s10 = sqrt(10.0);
gsl_matrix_set_zero(&J.matrix);
gsl_matrix_set(&J.matrix, 0, 0, -20.0*x1);
gsl_matrix_set(&J.matrix, 0, 1, 10.0);
gsl_matrix_set(&J.matrix, 1, 0, -1.0);
gsl_matrix_set(&J.matrix, 2, 2, -2.0*s90*x3);
gsl_matrix_set(&J.matrix, 2, 3, s90);
gsl_matrix_set(&J.matrix, 3, 2, -1.0);
gsl_matrix_set(&J.matrix, 4, 1, s10);
gsl_matrix_set(&J.matrix, 4, 3, s10);
gsl_matrix_set(&J.matrix, 5, 1, 1.0/s10);
gsl_matrix_set(&J.matrix, 5, 3, -1.0/s10);
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static int
meyer_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(meyer_J, meyer_N, meyer_P);
double x1 = gsl_vector_get(x, 0);
double x2 = gsl_vector_get(x, 1);
double x3 = gsl_vector_get(x, 2);
size_t i;
for (i = 0; i < meyer_N; ++i)
{
double ti = 45.0 + 5.0*(i + 1.0);
double term1 = ti + x3;
double term2 = exp(x2 / term1);
gsl_matrix_set(&J.matrix, i, 0, term2);
gsl_matrix_set(&J.matrix, i, 1, x1*term2/term1);
gsl_matrix_set(&J.matrix, i, 2, -x1*x2*term2/(term1*term1));
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static int
powell3_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(powell3_J, powell3_N, powell3_P);
double x1 = gsl_vector_get(x, 0);
double x2 = gsl_vector_get(x, 1);
gsl_matrix_set(&J.matrix, 0, 0, 1.0e4*x2);
gsl_matrix_set(&J.matrix, 0, 1, 1.0e4*x1);
gsl_matrix_set(&J.matrix, 1, 0, -exp(-x1));
gsl_matrix_set(&J.matrix, 1, 1, -exp(-x2));
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static int
beale_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(beale_J, beale_N, beale_P);
double x1 = gsl_vector_get(x, 0);
double x2 = gsl_vector_get(x, 1);
size_t i;
for (i = 0; i < beale_N; ++i)
{
double term = pow(x2, (double) i);
gsl_matrix_set(&J.matrix, i, 0, term*x2 - 1.0);
gsl_matrix_set(&J.matrix, i, 1, (i + 1.0) * x1 * term);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static int
lin2_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(lin2_J, lin2_N, lin2_P);
size_t i, j;
for (i = 0; i < lin2_N; ++i)
{
for (j = 0; j < lin2_P; ++j)
{
gsl_matrix_set(&J.matrix, i, j, (i + 1.0) * (j + 1.0));
}
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)x; /* avoid unused parameter warning */
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static int
wnlin_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(wnlin_J, wnlin_N, wnlin_P);
double A = gsl_vector_get (x, 0);
double lambda = gsl_vector_get (x, 1);
size_t i;
for (i = 0; i < wnlin_N; i++)
{
gsl_vector_view v = gsl_matrix_row(&J.matrix, i);
double ti = i;
double swi = sqrt(wnlin_W[i]);
double e = exp(-lambda * ti);
gsl_vector_set(&v.vector, 0, e);
gsl_vector_set(&v.vector, 1, -ti * A * e);
gsl_vector_set(&v.vector, 2, 1.0);
gsl_vector_scale(&v.vector, swi);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
return GSL_SUCCESS;
}
static int
box_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(box_J, box_N, box_P);
double x1 = gsl_vector_get(x, 0);
double x2 = gsl_vector_get(x, 1);
size_t i;
for (i = 0; i < box_N; ++i)
{
double ti = (i + 1.0) / 10.0;
double term1 = exp(-x1*ti);
double term2 = exp(-x2*ti);
double term3 = exp(-10.0*ti) - exp(-ti);
gsl_matrix_set(&J.matrix, i, 0, -ti*term1);
gsl_matrix_set(&J.matrix, i, 1, ti*term2);
gsl_matrix_set(&J.matrix, i, 2, term3);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
/* Compute Gibbs sampling pieces X'*y, and X'*X */
void olsg(gsl_vector *y, gsl_matrix *X, gsl_vector *XTy, gsl_matrix *XTX)
{
gsl_vector_set_all(XTy,0.0);
gsl_blas_dgemv (CblasTrans,1.0,X,y, 0.0 , XTy);
gsl_matrix_set_all(XTX,0.0);
/* XTX stored in lower triangle only */
gsl_blas_dsyrk (CblasLower, CblasTrans,1.0,X,0.0,XTX);
}
int
lls_fold(gsl_matrix *A, gsl_vector *b,
gsl_vector *wts, lls_workspace *w)
{
const size_t n = A->size1;
if (A->size2 != w->p)
{
GSL_ERROR("A has wrong size2", GSL_EBADLEN);
}
else if (n != b->size)
{
GSL_ERROR("b has wrong size", GSL_EBADLEN);
}
else if (n != wts->size)
{
GSL_ERROR("wts has wrong size", GSL_EBADLEN);
}
else
{
int s = 0;
size_t i;
double bnorm;
for (i = 0; i < n; ++i)
{
gsl_vector_view rv = gsl_matrix_row(A, i);
double *bi = gsl_vector_ptr(b, i);
double wi = gsl_vector_get(wts, i);
double swi = sqrt(wi);
/* A <- sqrt(W) A */
gsl_vector_scale(&rv.vector, swi);
/* b <- sqrt(W) b */
*bi *= swi;
}
/* ATA += A^T W A, using only the upper half of the matrix */
s = gsl_blas_dsyrk(CblasUpper, CblasTrans, 1.0, A, 1.0, w->ATA);
if (s)
return s;
/* ATb += A^T W b */
s = gsl_blas_dgemv(CblasTrans, 1.0, A, b, 1.0, w->ATb);
if (s)
return s;
/* bTb += b^T W b */
bnorm = gsl_blas_dnrm2(b);
w->bTb += bnorm * bnorm;
return s;
}
} /* lls_fold() */
int GlmTest::resampSmryCase(glm *model, gsl_matrix *bT, GrpMat *GrpXs, gsl_matrix *bO, unsigned int i )
{
gsl_set_error_handler_off();
int status, isValid=TRUE;
unsigned int j, k, id;
gsl_vector_view yj, oj, xj;
gsl_matrix *tXX = NULL;
unsigned int nRows=tm->nRows, nParam=tm->nParam;
if (bootID == NULL) {
tXX = gsl_matrix_alloc(nParam, nParam);
while (isValid==TRUE) { // if all isSingular==TRUE
if (tm->reprand!=TRUE) GetRNGstate();
for (j=0; j<nRows; j++) {
// resample Y, X, offsets accordingly
if (tm->reprand==TRUE)
id = (unsigned int) gsl_rng_uniform_int(rnd, nRows);
else id = (unsigned int) nRows * Rf_runif(0, 1);
xj = gsl_matrix_row(model->Xref, id);
gsl_matrix_set_row(GrpXs[0].matrix, j, &xj.vector);
yj = gsl_matrix_row(model->Yref, id);
gsl_matrix_set_row(bT, j, &yj.vector);
oj = gsl_matrix_row(model->Eta, id);
gsl_matrix_set_row(bO, j, &oj.vector);
}
if (tm->reprand!=TRUE) PutRNGstate();
gsl_matrix_set_identity(tXX);
gsl_blas_dsyrk(CblasLower,CblasTrans,1.0,GrpXs[0].matrix,0.0,tXX);
status=gsl_linalg_cholesky_decomp(tXX);
if (status!=GSL_EDOM) break;
// if (calcDet(tXX)>eps) break;
}
for (k=2; k<nParam+2; k++)
subX2(GrpXs[0].matrix, k-2, GrpXs[k].matrix);
}
else {
for (j=0; j<nRows; j++) {
id = (unsigned int) gsl_matrix_get(bootID, i, j);
// resample Y and X and offset
yj=gsl_matrix_row(model->Yref, id);
gsl_matrix_set_row (bT, j, &yj.vector);
oj = gsl_matrix_row(model->Eta, id);
gsl_matrix_set_row(bO, j, &oj.vector);
xj = gsl_matrix_row(model->Xref, id);
gsl_matrix_set_row(GrpXs[0].matrix, j, &xj.vector);
}
for (k=2; k<nParam+2; k++)
subX2(GrpXs[0].matrix, k-2, GrpXs[k].matrix);
}
gsl_matrix_free(tXX);
return SUCCESS;
}
//int GlmTest::resampAnovaCase(glm *model, gsl_matrix *Onull, gsl_matrix *bT, gsl_matrix *bX, gsl_matrix *bO, gsl_matrix *bOnull, unsigned int i)
int GlmTest::resampAnovaCase(glm *model, gsl_matrix *bT, gsl_matrix *bX, gsl_matrix *bO, unsigned int i)
{
gsl_set_error_handler_off();
int status, isValid=TRUE;
unsigned int j, id, nP;
gsl_vector_view yj, xj, oj;
nP = model->Xref->size2;
gsl_matrix *tXX = gsl_matrix_alloc(nP, nP);
unsigned int nRows=tm->nRows;
if (bootID == NULL) {
while (isValid==TRUE) {
if (tm->reprand!=TRUE) GetRNGstate();
for (j=0; j<nRows; j++) {
if (tm->reprand==TRUE)
id=(unsigned int)gsl_rng_uniform_int(rnd, nRows);
else id=(unsigned int) nRows*Rf_runif(0, 1);
// resample Y and X and offset
yj=gsl_matrix_row(model->Yref, id);
xj = gsl_matrix_row(model->Xref, id);
oj = gsl_matrix_row(model->Eta, id);
gsl_matrix_set_row (bT, j, &yj.vector);
gsl_matrix_set_row(bX, j, &xj.vector);
gsl_matrix_set_row(bO, j, &oj.vector);
}
if (tm->reprand!=TRUE) PutRNGstate();
gsl_matrix_set_identity(tXX);
gsl_blas_dsyrk(CblasLower,CblasTrans,1.0,bX,0.0,tXX);
status=gsl_linalg_cholesky_decomp(tXX);
if (status!=GSL_EDOM) break;
}
}
else {
for (j=0; j<nRows; j++) {
id = (unsigned int) gsl_matrix_get(bootID, i, j);
// resample Y and X and offset
yj=gsl_matrix_row(model->Yref, id);
xj = gsl_matrix_row(model->Xref, id);
oj = gsl_matrix_row(model->Oref, id);
gsl_matrix_set_row (bT, j, &yj.vector);
gsl_matrix_set_row(bX, j, &xj.vector);
gsl_matrix_set_row(bO, j, &oj.vector);
}
}
gsl_matrix_free(tXX);
return SUCCESS;
}
int rwishart(const gsl_rng *r, const unsigned int n, const unsigned int dof, const gsl_matrix *scale, gsl_matrix *result)
{
unsigned int k,l;
gsl_matrix *work = gsl_matrix_calloc(n,n);
for(k=0; k<n; k++){
gsl_matrix_set( work, k, k, sqrt( gsl_ran_chisq( r, (dof-k) ) ) );
for(l=0; l<k; l++)
gsl_matrix_set( work, k, l, gsl_ran_ugaussian(r) );
}
gsl_matrix_memcpy(result,scale);
gsl_linalg_cholesky_decomp(result);
gsl_blas_dtrmm(CblasLeft,CblasLower,CblasNoTrans,CblasNonUnit,1.0,result,work);
gsl_blas_dsyrk(CblasUpper,CblasNoTrans,1.0,work,0.0,result);
return 0;
}
static VALUE rb_gsl_blas_dsyrk(VALUE obj, VALUE u, VALUE t, VALUE a, VALUE aa,
VALUE b, VALUE cc)
{
gsl_matrix *A = NULL, *C = NULL;
double alpha, beta;
CBLAS_UPLO_t Uplo;
CBLAS_TRANSPOSE_t Trans;
CHECK_FIXNUM(u); CHECK_FIXNUM(t);
Need_Float(a); Need_Float(b);
CHECK_MATRIX(aa); CHECK_MATRIX(cc);
Uplo = FIX2INT(u);
Trans = FIX2INT(t);
alpha = NUM2DBL(a);
beta = NUM2DBL(b);
Data_Get_Struct(aa, gsl_matrix, A);
Data_Get_Struct(cc, gsl_matrix, C);
gsl_blas_dsyrk(Uplo, Trans, alpha, A, beta, C);
return cc;
}
static int
thurber_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(thurber_J, thurber_N, thurber_P);
double b[thurber_P];
size_t i;
for (i = 0; i < thurber_P; i++)
{
b[i] = gsl_vector_get(x, i);
}
for (i = 0; i < thurber_N; i++)
{
double xi = thurber_X[i];
double d, n, d_sq;
n = b[0] + b[1]*xi + b[2]*xi*xi + b[3]*xi*xi*xi;
d = 1.0 + b[4]*xi + b[5]*xi*xi + b[6]*xi*xi*xi;
d_sq = d * d;
gsl_matrix_set (&J.matrix, i, 0, 1.0 / d);
gsl_matrix_set (&J.matrix, i, 1, xi / d);
gsl_matrix_set (&J.matrix, i, 2, (xi * xi) / d);
gsl_matrix_set (&J.matrix, i, 3, (xi * xi * xi) / d);
gsl_matrix_set (&J.matrix, i, 4, -xi * n / d_sq);
gsl_matrix_set (&J.matrix, i, 5, -xi * xi * n / d_sq);
gsl_matrix_set (&J.matrix, i, 6, -xi * xi * xi * n / d_sq);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static VALUE rb_gsl_blas_dsyrk2(VALUE obj, VALUE u, VALUE t, VALUE a, VALUE aa,
VALUE b, VALUE cc)
{
gsl_matrix *A = NULL, *C = NULL, *Cnew = NULL;
double alpha, beta;
CBLAS_UPLO_t Uplo;
CBLAS_TRANSPOSE_t Trans;
CHECK_FIXNUM(u); CHECK_FIXNUM(t);
Need_Float(a); Need_Float(b);
CHECK_MATRIX(aa); CHECK_MATRIX(cc);
Uplo = FIX2INT(u);
Trans = FIX2INT(t);
alpha = NUM2DBL(a);
beta = NUM2DBL(b);
Data_Get_Struct(aa, gsl_matrix, A);
Data_Get_Struct(cc, gsl_matrix, C);
Cnew = gsl_matrix_alloc(C->size1, C->size2);
gsl_matrix_memcpy(Cnew, C);
gsl_blas_dsyrk(Uplo, Trans, alpha, A, beta, Cnew);
return Data_Wrap_Struct(cgsl_matrix, 0, gsl_matrix_free, Cnew);
}
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;
}
int main(int argc, char **argv) {
/* declare variables */
gsl_matrix *A, *C;
double arg;
size_t n;
unsigned int i,j;
long long complexity;
#ifdef HAVE_SETAFFINITY
cpu_set_t aff_mask;
#endif
/* parse arguments */
if(argc != NARGS+1) {
return PMM_EXIT_ARGFAIL;
}
if(sscanf(argv[1], "%lf", &arg) == 0) {
return PMM_EXIT_ARGPARSEFAIL;
}
n = (size_t)arg;
/* calculate complexity */
complexity = n*n*(long long)n;
#ifdef HAVE_SETAFFINITY
/* set processor affinity */
CPU_ZERO(&aff_mask);
CPU_SET(0, &aff_mask);
if(sched_setaffinity(0, sizeof(aff_mask), &aff_mask) < 0) {
printf("could not set affinity!\n");
return PMM_EXIT_ARGFAIL;
}
#endif
/* initialise data */
A = gsl_matrix_alloc(n, n);
C = gsl_matrix_alloc(n, n);
for(i=0; i<n; i++) {
for(j=0; j<n; j++) {
gsl_matrix_set(A, i, j, 10.0*(rand()/((double)RAND_MAX+1)));
if(j<n-i) {
gsl_matrix_set(C, i, j, 10.0*(rand()/((double)RAND_MAX+1)));
}
}
}
//gsl_matrix_set_all(A, 2.5);
//gsl_matrix_set_all(C, 7.3);
/* initialise timer */
pmm_timer_init(complexity);
/* start timer */
pmm_timer_start();
/* execute routine */
gsl_blas_dsyrk(CblasUpper, CblasNoTrans, 1.0, A, 1.0, C);
/* stop timer */
pmm_timer_stop();
/* get timing result */
pmm_timer_result();
/* destroy timer */
pmm_timer_destroy();
gsl_matrix_free(A);
gsl_matrix_free(C);
return PMM_EXIT_SUCCESS;
}
/**
* C++ version of gsl_blas_dsyrk().
* @param Uplo Upper or lower triangular
* @param Trans Transpose type
* @param alpha A constant
* @param A A matrix
* @param beta Another constant
* @param C Another matrix
* @return Error code on failure
*/
int dsyrk( CBLAS_UPLO_t Uplo, CBLAS_TRANSPOSE_t Trans, double alpha,
matrix const& A, double beta, matrix& C ){
return gsl_blas_dsyrk( Uplo, Trans, alpha, A.get(), beta, C.get() ); }
int
gsl_multifit_linear_Lsobolev(const size_t p, const size_t kmax,
const gsl_vector *alpha, gsl_matrix *L,
gsl_multifit_linear_workspace *work)
{
if (p > work->pmax)
{
GSL_ERROR("p is larger than workspace", GSL_EBADLEN);
}
else if (p <= kmax)
{
GSL_ERROR("p must be larger than derivative order", GSL_EBADLEN);
}
else if (kmax + 1 != alpha->size)
{
GSL_ERROR("alpha must be size kmax + 1", GSL_EBADLEN);
}
else if (p != L->size1)
{
GSL_ERROR("L matrix is wrong size", GSL_EBADLEN);
}
else if (L->size1 != L->size2)
{
GSL_ERROR("L matrix is not square", GSL_ENOTSQR);
}
else
{
int s;
size_t j, k;
gsl_vector_view d = gsl_matrix_diagonal(L);
const double alpha0 = gsl_vector_get(alpha, 0);
/* initialize L to alpha0^2 I */
gsl_matrix_set_zero(L);
gsl_vector_add_constant(&d.vector, alpha0 * alpha0);
for (k = 1; k <= kmax; ++k)
{
gsl_matrix_view Lk = gsl_matrix_submatrix(work->Q, 0, 0, p - k, p);
double ak = gsl_vector_get(alpha, k);
/* compute a_k L_k */
s = gsl_multifit_linear_Lk(p, k, &Lk.matrix);
if (s)
return s;
gsl_matrix_scale(&Lk.matrix, ak);
/* LTL += L_k^T L_k */
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &Lk.matrix, 1.0, L);
}
s = gsl_linalg_cholesky_decomp(L);
if (s)
return s;
/* copy Cholesky factor to upper triangle and zero out bottom */
gsl_matrix_transpose_tricpy('L', 1, L, L);
for (j = 0; j < p; ++j)
{
for (k = 0; k < j; ++k)
gsl_matrix_set(L, j, k, 0.0);
}
return GSL_SUCCESS;
}
}
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;
}
// Wald Test used in both summary and anova (polymophism)
int GlmTest::GeeWald(glm *Alt, gsl_matrix *LL, gsl_vector *teststat)
{
gsl_set_error_handler_off();
unsigned int i, j, l;
double alpha, result, sum=0;
unsigned int nP = Alt->nParams;
unsigned int nDF = LL->size1;
unsigned int nVars=tm->nVars, nRows=tm->nRows;
int status;
gsl_vector *LBeta = gsl_vector_alloc(nVars*nDF);
gsl_vector_set_zero(LBeta);
gsl_matrix *w1jX1=gsl_matrix_alloc(nRows, nP);
gsl_matrix *XwX=gsl_matrix_alloc(nP, nP);
gsl_matrix *Rl2 = gsl_matrix_alloc(nDF, nP);
gsl_matrix *IinvN = gsl_matrix_alloc(nDF, nDF);
gsl_matrix *IinvRl = gsl_matrix_alloc(nVars*nDF, nVars*nDF);
gsl_vector *tmp = gsl_vector_alloc(nVars*nDF);
gsl_vector_view tmp2, wj, LBj, bj; //, dj;
gsl_matrix_view Rl;
gsl_matrix_set_zero(IinvRl);
GrpMat *Z = (GrpMat*)malloc(nVars*sizeof(GrpMat));
for (j=0; j<nVars; j++){
Z[j].matrix = gsl_matrix_alloc(nP, nRows);
// w1jX1 = W^1/2 * X
wj=gsl_matrix_column(Alt->wHalf, j);
for (i=0; i<nP; i++)
gsl_matrix_set_col (w1jX1, i, &wj.vector);
gsl_matrix_mul_elements (w1jX1, Alt->Xref);
// LBeta = L*Beta
LBj=gsl_vector_subvector(LBeta, j*nDF, nDF);
bj=gsl_matrix_column(Alt->Beta, j);
gsl_blas_dgemv(CblasNoTrans,1,LL,&bj.vector,0,&LBj.vector);
// Z = (X^T W X)^-1 * X^T W^1/2.
gsl_matrix_set_identity(XwX);
gsl_blas_dsyrk (CblasLower,CblasTrans,1.0,w1jX1,0.0,XwX);
status=gsl_linalg_cholesky_decomp (XwX);
if (status==GSL_EDOM) {
if (tm->warning==TRUE)
printf("Warning:singular matrix in wald test. An eps*I is added to the singular matrix.\n");
gsl_matrix_set_identity(XwX);
gsl_blas_dsyrk(CblasLower,CblasTrans,1.0,w1jX1,eps,XwX);
gsl_linalg_cholesky_decomp(XwX);
}
gsl_linalg_cholesky_invert(XwX);
gsl_blas_dgemm(CblasNoTrans,CblasTrans,1.0,XwX,w1jX1,0.0, Z[j].matrix);
gsl_matrix_memcpy(Rl2, LL);
gsl_blas_dtrmm (CblasRight,CblasLower,CblasNoTrans,CblasNonUnit,1.0,XwX,Rl2); // L*(X'WX)^-1
gsl_blas_dgemm (CblasNoTrans, CblasTrans, 1.0, Rl2, LL, 0.0, IinvN); // L*(X^T*W*X)^-1*L^T
if ( (tm->punit!=NONE) || (tm->corr==IDENTITY) ) {
status=gsl_linalg_cholesky_decomp (IinvN);
if (status==GSL_EDOM) {
if (tm->warning==TRUE)
printf("Warning:singular IinvN in wald test.\n");
}
tmp2=gsl_vector_subvector(tmp, 0, nDF);
gsl_linalg_cholesky_solve (IinvN, &LBj.vector, &tmp2.vector);
gsl_blas_ddot (&LBj.vector, &tmp2.vector, &result);
gsl_vector_set(teststat, j+1, sqrt(result));
sum = sum + result;
}
if (tm->corr!=IDENTITY) {
// IinvRl=L*vSandRl*L^T
for (l=0; l<=j; l++) {
Rl=gsl_matrix_submatrix(IinvRl,j*nDF,l*nDF,nDF,nDF);
alpha = gsl_matrix_get(Rlambda, j, l);
// borrow XwX space to store vSandRl
gsl_blas_dgemm(CblasNoTrans,CblasTrans,alpha,Z[j].matrix,Z[l].matrix, 0.0, XwX);
// Rl2 = L*vSandRl*L^T
gsl_blas_dgemm(CblasNoTrans,CblasNoTrans,1.0,LL,XwX,0.0,Rl2);
gsl_blas_dgemm(CblasNoTrans,CblasTrans,1.0,Rl2,LL,0.0,&Rl.matrix);
} // end l
} // end if (tm->corr)
} // end for j=1:nVars
if ( tm->corr==IDENTITY )
gsl_vector_set(teststat, 0, sqrt(sum));
else {
status=gsl_linalg_cholesky_decomp (IinvRl);
if (status==GSL_EDOM) {
if (tm->warning==TRUE)
printf("Warning:singular matrix in multivariate wald test.\n");
}
gsl_linalg_cholesky_solve (IinvRl, LBeta, tmp);
gsl_blas_ddot (LBeta, tmp, &result);
gsl_vector_set(teststat, 0, sqrt(result));
}
// free memory
for (j=0; j<nVars; j++)
gsl_matrix_free(Z[j].matrix);
free(Z);
gsl_vector_free(LBeta);
gsl_matrix_free(w1jX1);
gsl_matrix_free(XwX);
gsl_matrix_free(Rl2);
gsl_matrix_free(IinvN);
gsl_matrix_free(IinvRl);
gsl_vector_free(tmp);
return SUCCESS;
}
int GlmTest::GeeScore(gsl_matrix *X1, glm *PtrNull, gsl_vector *teststat)
{
gsl_set_error_handler_off();
double result, alpha, sum=0;
unsigned int i, j, l, nP = X1->size2;
unsigned int nVars=tm->nVars, nRows=tm->nRows;
int status;
gsl_vector *U = gsl_vector_alloc(nVars*nP);
gsl_matrix *kRlNull = gsl_matrix_alloc(nVars*nP, nVars*nP);
gsl_matrix_set_zero (kRlNull);
gsl_matrix *XwX = gsl_matrix_alloc(nP, nP);
gsl_vector *tmp=gsl_vector_alloc(nVars*nP);
gsl_vector_view wj, uj, rj, tmp2; //, dj;
gsl_matrix_view Rl;
GrpMat *Z = (GrpMat*)malloc(nVars*sizeof(GrpMat));
for (j=0; j<nVars; j++) {
Z[j].matrix = gsl_matrix_alloc(nRows, nP);
// get W^1/2 * X
wj = gsl_matrix_column (PtrNull->wHalf, j);
for (i=0; i<nP; i++)
gsl_matrix_set_col (Z[j].matrix, i, &wj.vector);
gsl_matrix_mul_elements (Z[j].matrix, X1);
uj=gsl_vector_subvector(U, j*nP, nP);
rj=gsl_matrix_column(PtrNull->Res, j);
gsl_blas_dgemv(CblasTrans, 1, Z[j].matrix, &rj.vector, 0, &uj.vector);
if ( (tm->punit!=NONE) || (tm->corr==IDENTITY) ) {
gsl_matrix_set_identity(XwX);
gsl_blas_dsyrk(CblasLower, CblasTrans, 1, Z[j].matrix, 0, XwX);
status=gsl_linalg_cholesky_decomp(XwX);
if (status==GSL_EDOM) {
if (tm->warning==TRUE)
printf("Warning: singular matrix in score test. An eps*I is added to the singular matrix.\n");
gsl_matrix_set_identity(XwX);
gsl_blas_dsyrk(CblasLower,CblasTrans,1,Z[j].matrix,eps,XwX);
gsl_linalg_cholesky_decomp(XwX);
}
tmp2=gsl_vector_subvector(tmp, 0, nP);
gsl_linalg_cholesky_solve(XwX, &uj.vector, &tmp2.vector);
gsl_blas_ddot(&uj.vector, &tmp2.vector, &result);
gsl_vector_set(teststat, j+1, result);
sum = sum+result;
}
if ( tm->corr!=IDENTITY) {
for (l=0; l<=j; l++) { // lower half
alpha = gsl_matrix_get(Rlambda, j, l);
Rl=gsl_matrix_submatrix(kRlNull,j*nP,l*nP,nP,nP);
gsl_blas_dgemm(CblasTrans, CblasNoTrans, alpha, Z[j].matrix, Z[l].matrix, 0, &Rl.matrix);
}
}
} // end for j=1:nVars
// multivariate test stat
if ( tm->corr==IDENTITY ) gsl_vector_set(teststat, 0, sum);
else {
status=gsl_linalg_cholesky_decomp (kRlNull);
if (status==GSL_EDOM) {
if (tm->warning==TRUE)
printf("Warning:singular kRlNull in multivariate score test.\n");
}
gsl_linalg_cholesky_solve (kRlNull, U, tmp);
gsl_blas_ddot (U, tmp, &result);
gsl_vector_set(teststat, 0, result);
}
// clear memory
gsl_vector_free(U);
gsl_vector_free(tmp);
gsl_matrix_free(XwX);
gsl_matrix_free(kRlNull);
for (j=0; j<nVars; j++) gsl_matrix_free(Z[j].matrix);
free(Z);
return SUCCESS;
}
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 main(int argc, char **argv) {
const int MAX_ITER = 50;
const double RELTOL = 1e-2;
const double ABSTOL = 1e-4;
/*
* Some bookkeeping variables for MPI. The 'rank' of a process is its numeric id
* in the process pool. For example, if we run a program via `mpirun -np 4 foo', then
* the process ranks are 0 through 3. Here, N and size are the total number of processes
* running (in this example, 4).
*/
int rank;
int size;
MPI_Init(&argc, &argv); // Initialize the MPI execution environment
MPI_Comm_rank(MPI_COMM_WORLD, &rank); // Determine current running process
MPI_Comm_size(MPI_COMM_WORLD, &size); // Total number of processes
double N = (double) size; // Number of subsystems/slaves for ADMM
/* Read in local data */
int skinny; // A flag indicating whether the matrix A is fat or skinny
FILE *f;
int m, n;
int row, col;
double entry;
/*
* Subsystem n will look for files called An.dat and bn.dat
* in the current directory; these are its local data and do not need to be
* visible to any other processes. Note that
* m and n here refer to the dimensions of the *local* coefficient matrix.
*/
/* Read A */
char s[20];
sprintf(s, "data/A%d.dat", rank + 1);
printf("[%d] reading %s\n", rank, s);
f = fopen(s, "r");
if (f == NULL) {
printf("[%d] ERROR: %s does not exist, exiting.\n", rank, s);
exit(EXIT_FAILURE);
}
mm_read_mtx_array_size(f, &m, &n);
gsl_matrix *A = gsl_matrix_calloc(m, n);
for (int i = 0; i < m*n; i++) {
row = i % m;
col = floor(i/m);
fscanf(f, "%lf", &entry);
gsl_matrix_set(A, row, col, entry);
}
fclose(f);
/* Read b */
sprintf(s, "data/b%d.dat", rank + 1);
printf("[%d] reading %s\n", rank, s);
f = fopen(s, "r");
if (f == NULL) {
printf("[%d] ERROR: %s does not exist, exiting.\n", rank, s);
exit(EXIT_FAILURE);
}
mm_read_mtx_array_size(f, &m, &n);
gsl_vector *b = gsl_vector_calloc(m);
for (int i = 0; i < m; i++) {
fscanf(f, "%lf", &entry);
gsl_vector_set(b, i, entry);
}
fclose(f);
m = A->size1;
n = A->size2;
skinny = (m >= n);
/*
* These are all variables related to ADMM itself. There are many
* more variables than in the Matlab implementation because we also
* require vectors and matrices to store various intermediate results.
* The naming scheme follows the Matlab version of this solver.
*/
double rho = 1.0;
gsl_vector *x = gsl_vector_calloc(n);
gsl_vector *u = gsl_vector_calloc(n);
gsl_vector *z = gsl_vector_calloc(n);
gsl_vector *y = gsl_vector_calloc(n);
gsl_vector *r = gsl_vector_calloc(n);
gsl_vector *zprev = gsl_vector_calloc(n);
gsl_vector *zdiff = gsl_vector_calloc(n);
gsl_vector *q = gsl_vector_calloc(n);
gsl_vector *w = gsl_vector_calloc(n);
gsl_vector *Aq = gsl_vector_calloc(m);
gsl_vector *p = gsl_vector_calloc(m);
gsl_vector *Atb = gsl_vector_calloc(n);
double send[3]; // an array used to aggregate 3 scalars at once
double recv[3]; // used to receive the results of these aggregations
double nxstack = 0;
double nystack = 0;
double prires = 0;
double dualres = 0;
double eps_pri = 0;
double eps_dual = 0;
/* Precompute and cache factorizations */
gsl_blas_dgemv(CblasTrans, 1, A, b, 0, Atb); // Atb = A^T b
/*
* The lasso regularization parameter here is just hardcoded
* to 0.5 for simplicity. Using the lambda_max heuristic would require
* network communication, since it requires looking at the *global* A^T b.
*/
double lambda = 0.5;
if (rank == 0) {
printf("using lambda: %.4f\n", lambda);
}
gsl_matrix *L;
/* Use the matrix inversion lemma for efficiency; see section 4.2 of the paper */
if (skinny) {
/* L = chol(AtA + rho*I) */
L = gsl_matrix_calloc(n,n);
gsl_matrix *AtA = gsl_matrix_calloc(n,n);
gsl_blas_dsyrk(CblasLower, CblasTrans, 1, A, 0, AtA);
gsl_matrix *rhoI = gsl_matrix_calloc(n,n);
gsl_matrix_set_identity(rhoI);
gsl_matrix_scale(rhoI, rho);
gsl_matrix_memcpy(L, AtA);
gsl_matrix_add(L, rhoI);
gsl_linalg_cholesky_decomp(L);
gsl_matrix_free(AtA);
gsl_matrix_free(rhoI);
} else {
/* L = chol(I + 1/rho*AAt) */
L = gsl_matrix_calloc(m,m);
gsl_matrix *AAt = gsl_matrix_calloc(m,m);
gsl_blas_dsyrk(CblasLower, CblasNoTrans, 1, A, 0, AAt);
gsl_matrix_scale(AAt, 1/rho);
gsl_matrix *eye = gsl_matrix_calloc(m,m);
gsl_matrix_set_identity(eye);
gsl_matrix_memcpy(L, AAt);
gsl_matrix_add(L, eye);
gsl_linalg_cholesky_decomp(L);
gsl_matrix_free(AAt);
gsl_matrix_free(eye);
}
/* Main ADMM solver loop */
int iter = 0;
if (rank == 0) {
printf("%3s %10s %10s %10s %10s %10s\n", "#", "r norm", "eps_pri", "s norm", "eps_dual", "objective");
}
double startAllTime, endAllTime;
startAllTime = MPI_Wtime();
while (iter < MAX_ITER) {
/* u-update: u = u + x - z */
gsl_vector_sub(x, z);
gsl_vector_add(u, x);
/* x-update: x = (A^T A + rho I) \ (A^T b + rho z - y) */
gsl_vector_memcpy(q, z);
gsl_vector_sub(q, u);
gsl_vector_scale(q, rho);
gsl_vector_add(q, Atb); // q = A^T b + rho*(z - u)
double tmp, tmpq;
gsl_blas_ddot(x, x, &tmp);
gsl_blas_ddot(q, q, &tmpq);
if (skinny) {
/* x = U \ (L \ q) */
gsl_linalg_cholesky_solve(L, q, x);
} else {
/* x = q/rho - 1/rho^2 * A^T * (U \ (L \ (A*q))) */
gsl_blas_dgemv(CblasNoTrans, 1, A, q, 0, Aq);
gsl_linalg_cholesky_solve(L, Aq, p);
gsl_blas_dgemv(CblasTrans, 1, A, p, 0, x); /* now x = A^T * (U \ (L \ (A*q)) */
gsl_vector_scale(x, -1/(rho*rho));
gsl_vector_scale(q, 1/rho);
gsl_vector_add(x, q);
}
/*
* Message-passing: compute the global sum over all processors of the
* contents of w and t. Also, update z.
*/
gsl_vector_memcpy(w, x);
gsl_vector_add(w, u); // w = x + u
gsl_blas_ddot(r, r, &send[0]);
gsl_blas_ddot(x, x, &send[1]);
gsl_blas_ddot(u, u, &send[2]);
send[2] /= pow(rho, 2);
gsl_vector_memcpy(zprev, z);
// could be reduced to a single Allreduce call by concatenating send to w
MPI_Allreduce(w->data, z->data, n, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
MPI_Allreduce(send, recv, 3, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
prires = sqrt(recv[0]); /* sqrt(sum ||r_i||_2^2) */
nxstack = sqrt(recv[1]); /* sqrt(sum ||x_i||_2^2) */
nystack = sqrt(recv[2]); /* sqrt(sum ||y_i||_2^2) */
gsl_vector_scale(z, 1/N);
soft_threshold(z, lambda/(N*rho));
/* Termination checks */
/* dual residual */
gsl_vector_memcpy(zdiff, z);
gsl_vector_sub(zdiff, zprev);
dualres = sqrt(N) * rho * gsl_blas_dnrm2(zdiff); /* ||s^k||_2^2 = N rho^2 ||z - zprev||_2^2 */
/* compute primal and dual feasibility tolerances */
eps_pri = sqrt(n*N)*ABSTOL + RELTOL * fmax(nxstack, sqrt(N)*gsl_blas_dnrm2(z));
eps_dual = sqrt(n*N)*ABSTOL + RELTOL * nystack;
if (rank == 0) {
printf("%3d %10.4f %10.4f %10.4f %10.4f %10.4f\n", iter,
prires, eps_pri, dualres, eps_dual, objective(A, b, lambda, z));
}
if (prires <= eps_pri && dualres <= eps_dual) {
break;
}
/* Compute residual: r = x - z */
gsl_vector_memcpy(r, x);
gsl_vector_sub(r, z);
iter++;
}
/* Have the master write out the results to disk */
if (rank == 0) {
endAllTime = MPI_Wtime();
printf("Elapsed time is: %lf \n", endAllTime - startAllTime);
f = fopen("data/solution.dat", "w");
gsl_vector_fprintf(f, z, "%lf");
fclose(f);
}
MPI_Finalize(); /* Shut down the MPI execution environment */
/* Clear memory */
gsl_matrix_free(A);
gsl_matrix_free(L);
gsl_vector_free(b);
gsl_vector_free(x);
gsl_vector_free(u);
gsl_vector_free(z);
gsl_vector_free(y);
gsl_vector_free(r);
gsl_vector_free(w);
gsl_vector_free(zprev);
gsl_vector_free(zdiff);
gsl_vector_free(q);
gsl_vector_free(Aq);
gsl_vector_free(Atb);
gsl_vector_free(p);
return EXIT_SUCCESS;
}