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;
}
}
int wrap_gsl_linalg_SV_decomp(gsl_matrix* A, gsl_matrix* V, gsl_matrix* S,
gsl_matrix* work)
{
gsl_vector_view _S = gsl_matrix_diagonal(S);
gsl_vector_view _work = gsl_matrix_row(work, 0);
return gsl_linalg_SV_decomp(A, V, &_S.vector, &_work.vector);
}
int wrap_gsl_linalg_SV_solve(gsl_matrix* U, gsl_matrix* V, gsl_matrix* S,
const gsl_matrix* b, gsl_matrix* x)
{
gsl_vector_view _S = gsl_matrix_diagonal(S);
gsl_vector_const_view _b = gsl_matrix_const_column(b, 0);
gsl_vector_view _x = gsl_matrix_column(x, 0);
return gsl_linalg_SV_solve(U, V, &_S.vector, &_b.vector, &_x.vector);
}
// from http://lists.gnu.org/archive/html/help-gsl/2005-09/msg00007.html
gsl_matrix * mygsl_matrix_diagalloc(const gsl_vector * vec, const double x)
{
gsl_matrix * mat = gsl_matrix_alloc(vec->size, vec->size);
gsl_matrix_set_all(mat, x);
gsl_vector_view diag = gsl_matrix_diagonal(mat);
gsl_vector_memcpy(&diag.vector, vec);
return mat;
}
/*
Computes covariance using the renormalization above and adds it to
an existing matrix.
*/
void MultinomialCovariance(double alpha,
const gsl_vector* v,
gsl_matrix* m) {
double scale = gsl_blas_dsum(v);
gsl_blas_dger(-alpha / scale, v, v, m);
gsl_vector_view diag = gsl_matrix_diagonal(m);
gsl_blas_daxpy(alpha, v, &diag.vector);
}
int
lls_regularize(const double lambda, gsl_matrix *ATA)
{
int s;
gsl_vector_view d = gsl_matrix_diagonal(ATA);
s = gsl_vector_add_constant(&d.vector, lambda * lambda);
return s;
} /* lls_regularize() */
void StationaryCholesky::computeGammak( const gsl_matrix *Rt, double reg ) {
gsl_matrix_view submat;
for (size_t k = 0; k < getMu(); k++) {
submat = gsl_matrix_submatrix(myGammaK, 0, k * getD(), getD(), getD());
myStStruct->AtVkB(&submat.matrix, k, Rt, Rt, myTempVijtRt);
if (reg > 0) {
gsl_vector diag = gsl_matrix_diagonal(&submat.matrix).vector;
gsl_vector_add_constant(&diag, reg);
}
}
submat = gsl_matrix_submatrix(myGammaK, 0, getMu() * getD(), getD(), getD());
gsl_matrix_set_zero(&submat.matrix);
}
int main(){
int len = 3000;
gsl_vector *v = gsl_vector_alloc(len);
for (double i=0; i< len; i++) gsl_vector_set(v, i, 1./(i+1));
double square;
gsl_blas_ddot(v, v, &square);
printf("1 + (1/2)^2 + (1/3)^2 + ...= %g\n", square);
double pi_over_six = gsl_pow_2(M_PI)/6.;
Diff(square, pi_over_six);
/* Now using apop_dot, in a few forms.
First, vector-as-data dot itself.
If one of the inputs is a vector,
apop_dot puts the output in a vector-as-data:*/
apop_data *v_as_data = &(apop_data){.vector=v};
apop_data *vdotv = apop_dot(v_as_data, v_as_data);
Diff(gsl_vector_get(vdotv->vector, 0), pi_over_six);
/* Wrap matrix in an apop_data set. */
gsl_matrix *v_as_matrix = apop_vector_to_matrix(v);
apop_data dm = (apop_data){.matrix=v_as_matrix};
// (1 X len) vector dot (len X 1) matrix --- produce a scalar (one item vector).
apop_data *mdotv = apop_dot(v_as_data, &dm);
double scalarval = apop_data_get(mdotv);
Diff(scalarval, pi_over_six);
//(len X 1) dot (len X 1) --- bad dimensions.
apop_opts.verbose=-1; //don't print an error.
apop_data *mdotv2 = apop_dot(&dm, v_as_data);
apop_opts.verbose=0; //back to safety.
assert(mdotv2->error);
// If we want (len X 1) dot (1 X len) --> (len X len),
// use apop_vector_to_matrix.
apop_data dmr = (apop_data){.matrix=apop_vector_to_matrix(v, .row_col='r')};
apop_data *product_matrix = apop_dot(&dm, &dmr);
//The trace is the sum of squares:
gsl_vector_view trace = gsl_matrix_diagonal(product_matrix->matrix);
double tracesum = apop_sum(&trace.vector);
Diff(tracesum, pi_over_six);
apop_data_free(product_matrix);
gsl_matrix_free(dmr.matrix);
}
static double one_wishart_row(gsl_vector *in, void *ws_in){
wishartstruct_t *ws = ws_in;
gsl_matrix *invparams_dot_data = gsl_matrix_alloc(ws->len, ws->len);
apop_data *square= apop_data_alloc(ws->len, ws->len);
apop_data_unpack(in, square);
double datadet = apop_matrix_determinant(square->matrix);
assert(datadet);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1, ws->paraminv, square->matrix, 0, invparams_dot_data);
gsl_vector_view diag = gsl_matrix_diagonal(invparams_dot_data);
double trace = apop_sum(&diag.vector);
gsl_matrix_free(invparams_dot_data);
apop_data_free(square);
double out= log(datadet) * (ws->df - ws->len -1.)/2. - trace*ws->df/2.;
assert(isfinite(out));
return out;
}
static int
penalty1_df (const gsl_vector * x, void *params, gsl_matrix * J)
{
const double alpha = 1.0e-5;
const double sqrt_alpha = sqrt(alpha);
size_t i;
gsl_matrix_view m = gsl_matrix_submatrix(J, 0, 0, penalty1_P, penalty1_P);
gsl_vector_view diag = gsl_matrix_diagonal(&m.matrix);
gsl_matrix_set_zero(&m.matrix);
gsl_vector_set_all(&diag.vector, sqrt_alpha);
for (i = 0; i < penalty1_P; ++i)
{
double xi = gsl_vector_get(x, i);
gsl_matrix_set(J, penalty1_N - 1, i, 2.0 * xi);
}
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static int
fdfridge_df(const gsl_vector * x, void * params, gsl_matrix * J)
{
int status;
gsl_multifit_fdfridge *w = (gsl_multifit_fdfridge *) params;
const size_t n = w->n;
const size_t p = w->p;
gsl_matrix_view J_user = gsl_matrix_submatrix(J, 0, 0, n, p);
gsl_matrix_view J_tik = gsl_matrix_submatrix(J, n, 0, p, p);
gsl_vector_view diag = gsl_matrix_diagonal(&J_tik.matrix);
/* compute user supplied Jacobian */
status = gsl_multifit_eval_wdf(w->fdf, x, NULL, &J_user.matrix);
if (status)
return status;
if (w->L_diag)
{
/* store diag(L_diag) in Tikhonov portion of J */
gsl_matrix_set_zero(&J_tik.matrix);
gsl_vector_memcpy(&diag.vector, w->L_diag);
}
else if (w->L)
{
/* store L in Tikhonov portion of J */
gsl_matrix_memcpy(&J_tik.matrix, w->L);
}
else
{
/* store \lambda I_p in Tikhonov portion of J */
gsl_matrix_set_zero(&J_tik.matrix);
gsl_vector_set_all(&diag.vector, w->lambda);
}
return GSL_SUCCESS;
} /* fdfridge_df() */
int
penalty_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
struct model_params *par = (struct model_params *) params;
const size_t p = x->size;
size_t j;
/* store 2*x in last row of J */
for (j = 0; j < p; ++j)
{
double xj = gsl_vector_get(x, j);
gsl_spmatrix_set(par->J, p, j, 2.0 * xj);
}
/* compute v = op(J) u */
if (v)
gsl_spblas_dgemv(TransJ, 1.0, par->J, u, 0.0, v);
if (JTJ)
{
gsl_vector_view diag = gsl_matrix_diagonal(JTJ);
/* compute J^T J = [ alpha*I_p + 4 x x^T ] */
gsl_matrix_set_zero(JTJ);
/* store 4 x x^T in lower half of JTJ */
gsl_blas_dsyr(CblasLower, 4.0, x, JTJ);
/* add alpha to diag(JTJ) */
gsl_vector_add_constant(&diag.vector, par->alpha);
}
return GSL_SUCCESS;
}
void cov_shrinkage(gsl_matrix* mle, int n, gsl_matrix* result)
{
int p = mle->size1, i;
double temp = 0, alpha = 0, tau = 0, log_lambda_s = 0;
gsl_vector
*lambda_star = gsl_vector_calloc(p),
t, u,
*eigen_vals = gsl_vector_calloc(p),
*s_eigen_vals = gsl_vector_calloc(p);
gsl_matrix
*d = gsl_matrix_calloc(p,p),
*eigen_vects = gsl_matrix_calloc(p,p),
*s_eigen_vects = gsl_matrix_calloc(p,p),
*result1 = gsl_matrix_calloc(p,p);
// get eigen decomposition
sym_eigen(mle, eigen_vals, eigen_vects);
for (i = 0; i < p; i++)
{
// compute shrunken eigenvalues
temp = 0;
alpha = 1.0/(n+p+1-2*i);
vset(lambda_star, i, n * alpha * vget(eigen_vals, i));
}
// get diagonal mle and eigen decomposition
t = gsl_matrix_diagonal(d).vector;
u = gsl_matrix_diagonal(mle).vector;
gsl_vector_memcpy(&t, &u);
sym_eigen(d, s_eigen_vals, s_eigen_vects);
// compute tau^2
for (i = 0; i < p; i++)
log_lambda_s += log(vget(s_eigen_vals, i));
log_lambda_s = log_lambda_s/p;
for (i = 0; i < p; i++)
tau += pow(log(vget(lambda_star, i)) - log_lambda_s, 2)/(p + 4) - 2.0 / n;
// shrink \lambda* towards the structured eigenvalues
for (i = 0; i < p; i++)
vset(lambda_star, i,
exp((2.0/n)/((2.0/n) + tau) * log_lambda_s +
tau/((2.0/n) + tau) * log(vget(lambda_star, i))));
// put the eigenvalues in a diagonal matrix
t = gsl_matrix_diagonal(d).vector;
gsl_vector_memcpy(&t, lambda_star);
// reconstruct the covariance matrix
gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1, d, eigen_vects, 0, result1);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1, eigen_vects, result1, 0, result);
// clean up
gsl_vector_free(lambda_star);
gsl_vector_free(eigen_vals);
gsl_vector_free(s_eigen_vals);
gsl_matrix_free(d);
gsl_matrix_free(eigen_vects);
gsl_matrix_free(s_eigen_vects);
gsl_matrix_free(result1);
}
void
test_longley ()
{
gsl_multifit_linear_workspace * work =
gsl_multifit_linear_alloc (longley_n, longley_p);
gsl_multifit_robust_workspace * work_rob =
gsl_multifit_robust_alloc (gsl_multifit_robust_ols, longley_n, longley_p);
gsl_matrix_view X = gsl_matrix_view_array (longley_x, longley_n, longley_p);
gsl_vector_view y = gsl_vector_view_array (longley_y, longley_n);
gsl_vector * c = gsl_vector_alloc (longley_p);
gsl_vector * r = gsl_vector_alloc (longley_n);
gsl_matrix * cov = gsl_matrix_alloc (longley_p, longley_p);
double chisq, chisq_res;
double expected_c[7] = { -3482258.63459582,
15.0618722713733,
-0.358191792925910E-01,
-2.02022980381683,
-1.03322686717359,
-0.511041056535807E-01,
1829.15146461355 };
double expected_sd[7] = { 890420.383607373,
84.9149257747669,
0.334910077722432E-01,
0.488399681651699,
0.214274163161675,
0.226073200069370,
455.478499142212 } ;
double expected_chisq = 836424.055505915;
gsl_vector_view diag = gsl_matrix_diagonal (cov);
gsl_vector_view exp_c = gsl_vector_view_array(expected_c, longley_p);
gsl_vector_view exp_sd = gsl_vector_view_array(expected_sd, longley_p);
/* test unweighted least squares */
gsl_multifit_linear (&X.matrix, &y.vector, c, cov, &chisq, work);
gsl_multifit_linear_residuals(&X.matrix, &y.vector, c, r);
gsl_blas_ddot(r, r, &chisq_res);
test_longley_results("longley gsl_multifit_linear",
c, &exp_c.vector,
&diag.vector, &exp_sd.vector,
chisq, chisq_res, expected_chisq);
/* test robust least squares */
gsl_multifit_robust (&X.matrix, &y.vector, c, cov, work_rob);
test_longley_results("longley gsl_multifit_robust",
c, &exp_c.vector,
&diag.vector, &exp_sd.vector,
1.0, 1.0, 1.0);
/* test weighted least squares */
{
size_t i, j;
gsl_vector * w = gsl_vector_alloc (longley_n);
double expected_cov[7][7] = { { 8531122.56783558,
-166.727799925578, 0.261873708176346, 3.91188317230983,
1.1285582054705, -0.889550869422687, -4362.58709870581},
{-166.727799925578, 0.0775861253030891, -1.98725210399982e-05,
-0.000247667096727256, -6.82911920718824e-05, 0.000136160797527761,
0.0775255245956248},
{0.261873708176346, -1.98725210399982e-05, 1.20690316701888e-08,
1.66429546772984e-07, 3.61843600487847e-08, -6.78805814483582e-08,
-0.00013158719037715},
{3.91188317230983, -0.000247667096727256, 1.66429546772984e-07,
2.56665052544717e-06, 6.96541409215597e-07, -9.00858307771567e-07,
-0.00197260370663974},
{1.1285582054705, -6.82911920718824e-05, 3.61843600487847e-08,
6.96541409215597e-07, 4.94032602583969e-07, -9.8469143760973e-08,
-0.000576921112208274},
{-0.889550869422687, 0.000136160797527761, -6.78805814483582e-08,
-9.00858307771567e-07, -9.8469143760973e-08, 5.49938542664952e-07,
0.000430074434198215},
{-4362.58709870581, 0.0775255245956248, -0.00013158719037715,
-0.00197260370663974, -0.000576921112208274, 0.000430074434198215,
2.23229587481535 }} ;
gsl_vector_set_all (w, 1.0);
gsl_multifit_wlinear (&X.matrix, w, &y.vector, c, cov, &chisq, work);
gsl_multifit_linear_residuals(&X.matrix, &y.vector, c, r);
gsl_blas_ddot(r, r, &chisq_res);
test_longley_results("longley gsl_multifit_wlinear",
c, &exp_c.vector,
NULL, NULL,
chisq, chisq_res, expected_chisq);
for (i = 0; i < longley_p; i++)
{
for (j = 0; j < longley_p; j++)
{
gsl_test_rel (gsl_matrix_get(cov,i,j), expected_cov[i][j], 1e-7,
"longley gsl_multifit_wlinear cov(%d,%d)", i, j) ;
}
}
gsl_vector_free(w);
}
gsl_vector_free(c);
gsl_vector_free(r);
gsl_matrix_free(cov);
gsl_multifit_linear_free (work);
gsl_multifit_robust_free (work_rob);
} /* test_longley() */
int check_and_fix_covmat(gsl_matrix *covmat) {
int i, s, test;
double eigenval_i;
gsl_vector_view diag;
int nelt;
gsl_matrix *mat;
gsl_vector *eigenval;
gsl_vector *eigenval_temp;
gsl_eigen_symm_workspace *wval;
gsl_eigen_symmv_workspace *wvec;
gsl_matrix *Q;
gsl_matrix *Qinv;
gsl_matrix *Lambda;
gsl_matrix *temp;
gsl_permutation *pp;
nelt = covmat->size1;
mat=gsl_matrix_alloc(nelt,nelt);
wval = gsl_eigen_symm_alloc(nelt);
wvec = gsl_eigen_symmv_alloc(nelt);
eigenval = gsl_vector_alloc(nelt);
// don't destroy the input matrix!
gsl_matrix_memcpy(mat, covmat);
// calculate eigenvalues...
gsl_eigen_symm(mat, eigenval, wval);
// test if the eigenvalues are negative...
test = 0;
for (i=0;i<nelt;i++) {
eigenval_i = gsl_vector_get(eigenval,i);
if (eigenval_i < MIN_EIGENVAL) {
test = 1;
gsl_vector_set(eigenval,i,MIN_EIGENVAL);
}
}
if (test) {
// initialize
Q=gsl_matrix_alloc(nelt,nelt);
Qinv=gsl_matrix_alloc(nelt,nelt);
Lambda=gsl_matrix_alloc(nelt,nelt);
temp=gsl_matrix_alloc(nelt,nelt);
eigenval_temp=gsl_vector_alloc(nelt);
pp=gsl_permutation_alloc(nelt);
// reset the matrix
gsl_matrix_memcpy(mat, covmat);
// calculate eigenvalues and eigenvector matrix Q
gsl_eigen_symmv(mat, eigenval_temp, Q, wvec);
// invert eigenvector matrix Q-> Qinv (leaving Q in place)
gsl_matrix_memcpy(temp,Q);
gsl_linalg_LU_decomp(temp, pp, &s);
gsl_linalg_LU_invert(temp, pp, Qinv);
// create a diagonal matrix Lambda
diag = gsl_matrix_diagonal(Lambda);
gsl_matrix_set_zero(Lambda);
gsl_vector_memcpy(&diag.vector, eigenval);
// do the multiplication
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Q, Lambda, 0.0, temp);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, temp, Qinv, 0.0, covmat);
gsl_matrix_free(Q);
gsl_matrix_free(Qinv);
gsl_matrix_free(Lambda);
gsl_matrix_free(temp);
gsl_vector_free(eigenval_temp);
gsl_permutation_free(pp);
}
gsl_matrix_free(mat);
gsl_vector_free(eigenval);
gsl_eigen_symm_free(wval);
gsl_eigen_symmv_free(wvec);
return 0;
}
/* solve standard form system with given lambda and test against
* normal equations solution, L = I */
static void
test_reg2(const double lambda, const gsl_matrix * X, const gsl_vector * y,
const gsl_vector * wts, const double tol,
gsl_multifit_linear_workspace * w, const char * desc)
{
const size_t n = X->size1;
const size_t p = X->size2;
double rnorm0, snorm0;
double rnorm1, snorm1;
gsl_vector *c0 = gsl_vector_alloc(p);
gsl_vector *c1 = gsl_vector_alloc(p);
gsl_matrix *XTX = gsl_matrix_alloc(p, p); /* X^T W X + lambda^2 I */
gsl_vector *XTy = gsl_vector_alloc(p); /* X^T W y */
gsl_matrix *Xs = gsl_matrix_alloc(n, p);
gsl_vector *ys = gsl_vector_alloc(n);
gsl_vector_view xtx_diag = gsl_matrix_diagonal(XTX);
gsl_permutation *perm = gsl_permutation_alloc(p);
gsl_vector *r = gsl_vector_alloc(n);
int signum;
size_t j;
/* compute Xs = sqrt(W) X and ys = sqrt(W) y */
gsl_multifit_linear_wstdform1(NULL, X, wts, y, Xs, ys, w);
/* construct XTy = X^T W y */
gsl_blas_dgemv(CblasTrans, 1.0, Xs, ys, 0.0, XTy);
/* construct XTX = X^T W X + lambda^2 I */
gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, Xs, Xs, 0.0, XTX);
gsl_vector_add_constant(&xtx_diag.vector, lambda*lambda);
/* solve XTX c = XTy with LU decomp */
gsl_linalg_LU_decomp(XTX, perm, &signum);
gsl_linalg_LU_solve(XTX, perm, XTy, c0);
/* compute SVD of X */
gsl_multifit_linear_svd(Xs, w);
/* solve regularized standard form system with lambda */
gsl_multifit_linear_solve(lambda, Xs, ys, c1, &rnorm0, &snorm0, w);
/* test snorm = ||c1|| */
snorm1 = gsl_blas_dnrm2(c1);
gsl_test_rel(snorm0, snorm1, tol, "test_reg2: %s, snorm lambda=%g n=%zu p=%zu",
desc, lambda, n, p);
/* test rnorm = ||y - X c1|| */
gsl_vector_memcpy(r, ys);
gsl_blas_dgemv(CblasNoTrans, -1.0, Xs, c1, 1.0, r);
rnorm1 = gsl_blas_dnrm2(r);
gsl_test_rel(rnorm0, rnorm1, tol, "test_reg2: %s, rnorm lambda=%g n=%zu p=%zu",
desc, lambda, n, p);
/* test c0 = c1 */
for (j = 0; j < p; ++j)
{
double c0j = gsl_vector_get(c0, j);
double c1j = gsl_vector_get(c1, j);
gsl_test_rel(c1j, c0j, tol, "test_reg2: %s, c0/c1 lambda=%g n=%zu p=%zu",
desc, lambda, n, p);
}
gsl_matrix_free(XTX);
gsl_vector_free(XTy);
gsl_matrix_free(Xs);
gsl_vector_free(ys);
gsl_vector_free(c0);
gsl_vector_free(c1);
gsl_vector_free(r);
gsl_permutation_free(perm);
}
void KFKSDS_deriv_C (int *dim, double *sy, double *sZ, double *sT, double *sH,
double *sR, double *sV, double *sQ, double *sa0, double *sP0, double *dvof,
double *epshat, double *vareps, double *etahat, double *vareta,
double *r, double *N, double *dr, double *dN,
double *dahat, double *dvareps)
{
//int s, p = dim[1], mp1 = m + 1;
int i, ip1, j, k, n = dim[0], m = dim[2],
ir = dim[3], rp1 = ir + 1, nrp1 = n * rp1,
rp1m = rp1 * m, iaux, irp1m,
irsod = ir * sizeof(double), msod = m * sizeof(double),
nsod = n * sizeof(double), rp1msod = rp1 * msod;
//double invf[n], vof[n], msHsq, dfinvfsq[nrp1];
double msHsq;
std::vector<double> invf(n);
std::vector<double> vof(n);
std::vector<double> dfinvfsq(nrp1);
gsl_matrix_view Q = gsl_matrix_view_array(sQ, m, m);
gsl_vector_view Z = gsl_vector_view_array(sZ, m);
gsl_vector * Z_cp = gsl_vector_alloc(m);
gsl_matrix * ZtZ = gsl_matrix_alloc(m, m);
gsl_matrix_view maux1, maux2;
maux1 = gsl_matrix_view_array(gsl_vector_ptr(&Z.vector, 0), m, 1);
gsl_vector_memcpy(Z_cp, &Z.vector);
maux2 = gsl_matrix_view_array(gsl_vector_ptr(Z_cp, 0), 1, m);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, &maux1.matrix,
&maux2.matrix, 0.0, ZtZ);
gsl_matrix * a_pred = gsl_matrix_alloc(n, m);
std::vector<gsl_matrix*> P_pred(n);
gsl_matrix * K = gsl_matrix_alloc(n, m);
gsl_vector_view K_irow;
std::vector<gsl_matrix*> L(n);
gsl_vector_view Qdiag = gsl_matrix_diagonal(&Q.matrix);
gsl_vector * Qdiag_msq = gsl_vector_alloc(m);
gsl_vector_memcpy(Qdiag_msq, &Qdiag.vector);
gsl_vector_mul(Qdiag_msq, &Qdiag.vector);
gsl_vector_scale(Qdiag_msq, -1.0);
std::vector<gsl_matrix*> da_pred(rp1);
std::vector< std::vector<gsl_matrix*> > dP_pred(n, std::vector<gsl_matrix*>(rp1));
std::vector<gsl_matrix*> dK(n);
// filtering
KF_deriv_aux_C(dim, sy, sZ, sT, sH, sR, sV, sQ, sa0, sP0,
&invf, &vof, dvof, &dfinvfsq, a_pred, &P_pred, K,
&L, &da_pred, &dP_pred, &dK);
// state vector smoothing and disturbances smoothing
gsl_matrix_view V = gsl_matrix_view_array(sV, ir, ir);
gsl_matrix_view R = gsl_matrix_view_array(sR, m, ir);
gsl_vector_view vaux;
gsl_vector *vaux2 = gsl_vector_alloc(m);
gsl_matrix *Mmm = gsl_matrix_alloc(m, m);
gsl_matrix *Mmm2 = gsl_matrix_alloc(m, m);
gsl_matrix *Mrm = gsl_matrix_alloc(ir, m);
gsl_vector_memcpy(Z_cp, &Z.vector);
gsl_matrix *r0 = gsl_matrix_alloc(n + 1, m);
gsl_vector_view r_row_t;
gsl_vector_view r_row_tp1 = gsl_matrix_row(r0, n);
gsl_vector_set_zero(&r_row_tp1.vector);
std::vector<gsl_matrix*> N0(n + 1);
N0.at(n) = gsl_matrix_calloc(m, m);
gsl_vector_view Ndiag;
gsl_vector *var_eps = gsl_vector_alloc(n);
msHsq = -1.0 * pow(*sH, 2);
//vaux = gsl_vector_view_array(invf, n);
vaux = gsl_vector_view_array(&invf[0], n);
gsl_vector_set_all(var_eps, msHsq);
gsl_vector_mul(var_eps, &vaux.vector);
gsl_vector_add_constant(var_eps, *sH);
gsl_vector *vr = gsl_vector_alloc(ir);
gsl_matrix *dL = gsl_matrix_alloc(m, m);
std::vector<gsl_matrix*> dr0(n + 1);
dr0.at(n) = gsl_matrix_calloc(rp1, m);
gsl_vector_view dr_row_t, dr_row_tp1;
std::vector< std::vector<gsl_matrix*> > dN0(n + 1, std::vector<gsl_matrix*>(rp1));
for (j = 0; j < rp1; j++)
{
(dN0.at(n)).at(j) = gsl_matrix_calloc(m, m);
}
for (i = n-1; i > -1; i--)
{
ip1 = i + 1;
iaux = (i-1) * rp1m;
irp1m = i * rp1m;
if (i != n-1) //the case i=n-1 was initialized above
r_row_tp1 = gsl_matrix_row(r0, ip1);
r_row_t = gsl_matrix_row(r0, i);
gsl_blas_dgemv(CblasTrans, 1.0, L.at(i), &r_row_tp1.vector,
0.0, &r_row_t.vector);
gsl_vector_memcpy(Z_cp, &Z.vector);
gsl_vector_scale(Z_cp, vof.at(i));
gsl_vector_add(&r_row_t.vector, Z_cp);
gsl_vector_memcpy(vaux2, &r_row_tp1.vector);
memcpy(&r[i * m], vaux2->data, msod);
N0.at(i) = gsl_matrix_alloc(m, m);
gsl_matrix_memcpy(N0.at(i), ZtZ);
gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, L.at(i), N0.at(ip1), 0.0, Mmm);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm, L.at(i), invf.at(i), N0.at(i));
vaux = gsl_matrix_diagonal(N0.at(ip1));
gsl_vector_memcpy(vaux2, &vaux.vector);
memcpy(&N[i * m], vaux2->data, msod);
K_irow = gsl_matrix_row(K, i);
gsl_blas_ddot(&K_irow.vector, &r_row_tp1.vector, &epshat[i]);
epshat[i] -= vof.at(i);
epshat[i] *= -*sH;
maux1 = gsl_matrix_view_array(gsl_vector_ptr(&K_irow.vector, 0), 1, m);
maux2 = gsl_matrix_view_array(gsl_vector_ptr(Z_cp, 0), 1, m);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, &maux1.matrix, N0.at(ip1),
0.0, &maux2.matrix);
vaux = gsl_vector_view_array(gsl_vector_ptr(var_eps, i), 1);
gsl_blas_dgemv(CblasNoTrans, msHsq, &maux2.matrix, &K_irow.vector,
1.0, &vaux.vector);
gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, &V.matrix, &R.matrix,
0.0, Mrm);
gsl_blas_dgemv(CblasNoTrans, 1.0, Mrm, &r_row_tp1.vector,
0.0, vr);
memcpy(&etahat[i*ir], vr->data, irsod);
Ndiag = gsl_matrix_diagonal(N0.at(ip1));
gsl_vector_memcpy(Z_cp, &Ndiag.vector);
gsl_vector_mul(Z_cp, Qdiag_msq);
gsl_vector_add(Z_cp, &Qdiag.vector);
gsl_blas_dgemv(CblasTrans, 1.0, &R.matrix, Z_cp, 0.0, vr);
memcpy(&vareta[i*ir], vr->data, irsod);
// derivatives
dr0.at(i) = gsl_matrix_alloc(rp1, m);
for (j = 0; j < rp1; j++)
{
k = i + j * n;
gsl_vector_memcpy(Z_cp, &Z.vector);
gsl_vector_scale(Z_cp, dvof[k]);
vaux = gsl_matrix_row(dK.at(i), j);
maux1 = gsl_matrix_view_array(gsl_vector_ptr(&vaux.vector, 0), m, 1);
maux2 = gsl_matrix_view_array(gsl_vector_ptr(&Z.vector, 0), 1, m);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, -1.0, &maux1.matrix,
&maux2.matrix, 0.0, dL);
dr_row_t = gsl_matrix_row(dr0.at(i), j);
dr_row_tp1 = gsl_matrix_row(dr0.at(ip1), j);
gsl_blas_dgemv(CblasTrans, 1.0, dL, &r_row_tp1.vector, 0.0, &dr_row_t.vector);
gsl_vector_add(&dr_row_t.vector, Z_cp);
gsl_blas_dgemv(CblasTrans, 1.0, L.at(i), &dr_row_tp1.vector, 1.0, &dr_row_t.vector);
(dN0.at(i)).at(j) = gsl_matrix_alloc(m, m);
gsl_matrix_memcpy((dN0.at(i)).at(j), ZtZ);
gsl_matrix_scale((dN0.at(i)).at(j), -1.0 * dfinvfsq.at(k));
gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, dL, N0.at(ip1), 0.0, Mmm);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm, L.at(i),
1.0, (dN0.at(i)).at(j));
gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, L.at(i),
(dN0.at(ip1)).at(j), 0.0, Mmm);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm, L.at(i),
1.0, (dN0.at(i)).at(j));
gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, L.at(i),
N0.at(ip1), 0.0, Mmm);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm, dL,
1.0, (dN0.at(i)).at(j));
if (i != 0)
{
vaux = gsl_matrix_diagonal((dN0.at(i)).at(j));
gsl_vector_memcpy(vaux2, &vaux.vector);
memcpy(&dN[iaux + j * m], vaux2->data, msod);
}
vaux = gsl_matrix_row(da_pred.at(j), i);
gsl_blas_dgemv(CblasNoTrans, 1.0, (dP_pred.at(i)).at(j) , &r_row_t.vector,
1.0, &vaux.vector);
gsl_blas_dgemv(CblasNoTrans, 1.0, P_pred.at(i), &dr_row_t.vector,
1.0, &vaux.vector);
gsl_vector_memcpy(vaux2, &vaux.vector);
memcpy(&dahat[irp1m + j * m], vaux2->data, msod);
gsl_matrix_memcpy(Mmm, (dP_pred.at(i)).at(j));
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, -1.0, (dP_pred.at(i)).at(j),
N0.at(i), 0.0, Mmm2);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm2, P_pred.at(i),
1.0, Mmm);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, -1.0, P_pred.at(i),
(dN0.at(i)).at(j), 0.0, Mmm2);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm2, P_pred.at(i),
1.0, Mmm);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, -1.0, P_pred.at(i),
N0.at(i), 0.0, Mmm2);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm2,
(dP_pred.at(i)).at(j), 1.0, Mmm);
gsl_matrix_mul_elements(Mmm, ZtZ);
std::vector<double> vmm(Mmm->data, Mmm->data + m*m);
dvareps[i*rp1 + j] = std::accumulate(vmm.begin(), vmm.end(), 0.0);
gsl_matrix_free((dN0.at(ip1)).at(j));
gsl_matrix_free((dP_pred.at(i)).at(j));
}
if (i != 0)
{
memcpy(&dr[iaux], (dr0.at(i))->data, rp1msod);
}
gsl_matrix_free(dr0.at(ip1));
gsl_matrix_free(dK.at(i));
gsl_matrix_free(P_pred.at(i));
gsl_matrix_free(L.at(i));
gsl_matrix_free(N0.at(ip1));
}
gsl_matrix_free(N0.at(0));
gsl_matrix_free(dr0.at(0));
for (j = 0; j < rp1; j++)
{
gsl_matrix_free((dN0.at(0)).at(j));
gsl_matrix_free(da_pred.at(j));
}
memcpy(&vareps[0], var_eps->data, nsod);
gsl_matrix_free(Mmm);
gsl_matrix_free(Mmm2);
gsl_matrix_free(Mrm);
gsl_matrix_free(r0);
gsl_matrix_free(K);
gsl_matrix_free(dL);
gsl_matrix_free(a_pred);
gsl_vector_free(Z_cp);
gsl_matrix_free(ZtZ);
gsl_vector_free(var_eps);
gsl_vector_free(vr);
gsl_vector_free(Qdiag_msq);
gsl_vector_free(vaux2);
}}
void
test_pontius ()
{
size_t i, j;
{
gsl_multifit_linear_workspace * work =
gsl_multifit_linear_alloc (pontius_n, pontius_p);
gsl_matrix * X = gsl_matrix_alloc (pontius_n, pontius_p);
gsl_vector_view y = gsl_vector_view_array (pontius_y, pontius_n);
gsl_vector * c = gsl_vector_alloc (pontius_p);
gsl_vector * r = gsl_vector_alloc (pontius_n);
gsl_matrix * cov = gsl_matrix_alloc (pontius_p, pontius_p);
gsl_vector_view diag;
double chisq;
double expected_c[3] = { 0.673565789473684E-03,
0.732059160401003E-06,
-0.316081871345029E-14};
double expected_sd[3] = { 0.107938612033077E-03,
0.157817399981659E-09,
0.486652849992036E-16 };
double expected_chisq = 0.155761768796992E-05;
for (i = 0 ; i < pontius_n; i++)
{
for (j = 0; j < pontius_p; j++)
{
gsl_matrix_set(X, i, j, pow(pontius_x[i], j));
}
}
gsl_multifit_linear (X, &y.vector, c, cov, &chisq, work);
gsl_test_rel (gsl_vector_get(c,0), expected_c[0], 1e-10, "pontius gsl_fit_multilinear c0") ;
gsl_test_rel (gsl_vector_get(c,1), expected_c[1], 1e-10, "pontius gsl_fit_multilinear c1") ;
gsl_test_rel (gsl_vector_get(c,2), expected_c[2], 1e-10, "pontius gsl_fit_multilinear c2") ;
diag = gsl_matrix_diagonal (cov);
gsl_test_rel (gsl_vector_get(&diag.vector,0), pow(expected_sd[0],2.0), 1e-10, "pontius gsl_fit_multilinear cov00") ;
gsl_test_rel (gsl_vector_get(&diag.vector,1), pow(expected_sd[1],2.0), 1e-10, "pontius gsl_fit_multilinear cov11") ;
gsl_test_rel (gsl_vector_get(&diag.vector,2), pow(expected_sd[2],2.0), 1e-10, "pontius gsl_fit_multilinear cov22") ;
gsl_test_rel (chisq, expected_chisq, 1e-10, "pontius gsl_fit_multilinear chisq") ;
gsl_multifit_linear_residuals(X, &y.vector, c, r);
gsl_blas_ddot(r, r, &chisq);
gsl_test_rel (chisq, expected_chisq, 1e-10, "pontius gsl_fit_multilinear residuals") ;
gsl_vector_free(c);
gsl_vector_free(r);
gsl_matrix_free(cov);
gsl_matrix_free(X);
gsl_multifit_linear_free (work);
}
{
gsl_multifit_linear_workspace * work =
gsl_multifit_linear_alloc (pontius_n, pontius_p);
gsl_matrix * X = gsl_matrix_alloc (pontius_n, pontius_p);
gsl_vector_view y = gsl_vector_view_array (pontius_y, pontius_n);
gsl_vector * w = gsl_vector_alloc (pontius_n);
gsl_vector * c = gsl_vector_alloc (pontius_p);
gsl_vector * r = gsl_vector_alloc (pontius_n);
gsl_matrix * cov = gsl_matrix_alloc (pontius_p, pontius_p);
double chisq;
double expected_c[3] = { 0.673565789473684E-03,
0.732059160401003E-06,
-0.316081871345029E-14};
double expected_chisq = 0.155761768796992E-05;
double expected_cov[3][3] ={
{2.76754385964916e-01 , -3.59649122807024e-07, 9.74658869395731e-14},
{-3.59649122807024e-07, 5.91630591630603e-13, -1.77210703526497e-19},
{9.74658869395731e-14, -1.77210703526497e-19, 5.62573661988878e-26} };
for (i = 0 ; i < pontius_n; i++)
{
for (j = 0; j < pontius_p; j++)
{
gsl_matrix_set(X, i, j, pow(pontius_x[i], j));
}
}
gsl_vector_set_all (w, 1.0);
gsl_multifit_wlinear (X, w, &y.vector, c, cov, &chisq, work);
gsl_test_rel (gsl_vector_get(c,0), expected_c[0], 1e-10, "pontius gsl_fit_multilinear c0") ;
gsl_test_rel (gsl_vector_get(c,1), expected_c[1], 1e-10, "pontius gsl_fit_multilinear c1") ;
gsl_test_rel (gsl_vector_get(c,2), expected_c[2], 1e-10, "pontius gsl_fit_multilinear c2") ;
for (i = 0; i < pontius_p; i++)
{
for (j = 0; j < pontius_p; j++)
{
gsl_test_rel (gsl_matrix_get(cov,i,j), expected_cov[i][j], 1e-10,
"pontius gsl_fit_wmultilinear cov(%d,%d)", i, j) ;
}
}
gsl_test_rel (chisq, expected_chisq, 1e-10, "pontius gsl_fit_wmultilinear chisq") ;
gsl_multifit_linear_residuals(X, &y.vector, c, r);
gsl_blas_ddot(r, r, &chisq);
gsl_test_rel (chisq, expected_chisq, 1e-10, "pontius gsl_fit_wmultilinear residuals") ;
gsl_vector_free(w);
gsl_vector_free(c);
gsl_vector_free(r);
gsl_matrix_free(cov);
gsl_matrix_free(X);
gsl_multifit_linear_free (work);
}
}
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;
}
}
void
test_filip ()
{
size_t i, j;
{
gsl_multifit_linear_workspace * work =
gsl_multifit_linear_alloc (filip_n, filip_p);
gsl_matrix * X = gsl_matrix_alloc (filip_n, filip_p);
gsl_vector_view y = gsl_vector_view_array (filip_y, filip_n);
gsl_vector * c = gsl_vector_alloc (filip_p);
gsl_matrix * cov = gsl_matrix_alloc (filip_p, filip_p);
gsl_vector_view diag;
double chisq;
double expected_c[11] = { -1467.48961422980,
-2772.17959193342,
-2316.37108160893,
-1127.97394098372,
-354.478233703349,
-75.1242017393757,
-10.8753180355343,
-1.06221498588947,
-0.670191154593408E-01,
-0.246781078275479E-02,
-0.402962525080404E-04 };
double expected_sd[11] = { 298.084530995537,
559.779865474950,
466.477572127796,
227.204274477751,
71.6478660875927,
15.2897178747400,
2.23691159816033,
0.221624321934227,
0.142363763154724E-01,
0.535617408889821E-03,
0.896632837373868E-05 };
double expected_chisq = 0.795851382172941E-03;
for (i = 0 ; i < filip_n; i++)
{
for (j = 0; j < filip_p; j++)
{
gsl_matrix_set(X, i, j, pow(filip_x[i], j));
}
}
gsl_multifit_linear (X, &y.vector, c, cov, &chisq, work);
gsl_test_rel (gsl_vector_get(c,0), expected_c[0], 1e-7, "filip gsl_fit_multilinear c0") ;
gsl_test_rel (gsl_vector_get(c,1), expected_c[1], 1e-7, "filip gsl_fit_multilinear c1") ;
gsl_test_rel (gsl_vector_get(c,2), expected_c[2], 1e-7, "filip gsl_fit_multilinear c2") ;
gsl_test_rel (gsl_vector_get(c,3), expected_c[3], 1e-7, "filip gsl_fit_multilinear c3") ;
gsl_test_rel (gsl_vector_get(c,4), expected_c[4], 1e-7, "filip gsl_fit_multilinear c4") ;
gsl_test_rel (gsl_vector_get(c,5), expected_c[5], 1e-7, "filip gsl_fit_multilinear c5") ;
gsl_test_rel (gsl_vector_get(c,6), expected_c[6], 1e-7, "filip gsl_fit_multilinear c6") ;
gsl_test_rel (gsl_vector_get(c,7), expected_c[7], 1e-7, "filip gsl_fit_multilinear c7") ;
gsl_test_rel (gsl_vector_get(c,8), expected_c[8], 1e-7, "filip gsl_fit_multilinear c8") ;
gsl_test_rel (gsl_vector_get(c,9), expected_c[9], 1e-7, "filip gsl_fit_multilinear c9") ;
gsl_test_rel (gsl_vector_get(c,10), expected_c[10], 1e-7, "filip gsl_fit_multilinear c10") ;
diag = gsl_matrix_diagonal (cov);
gsl_test_rel (gsl_vector_get(&diag.vector,0), pow(expected_sd[0],2.0), 1e-6, "filip gsl_fit_multilinear cov00") ;
gsl_test_rel (gsl_vector_get(&diag.vector,1), pow(expected_sd[1],2.0), 1e-6, "filip gsl_fit_multilinear cov11") ;
gsl_test_rel (gsl_vector_get(&diag.vector,2), pow(expected_sd[2],2.0), 1e-6, "filip gsl_fit_multilinear cov22") ;
gsl_test_rel (gsl_vector_get(&diag.vector,3), pow(expected_sd[3],2.0), 1e-6, "filip gsl_fit_multilinear cov33") ;
gsl_test_rel (gsl_vector_get(&diag.vector,4), pow(expected_sd[4],2.0), 1e-6, "filip gsl_fit_multilinear cov44") ;
gsl_test_rel (gsl_vector_get(&diag.vector,5), pow(expected_sd[5],2.0), 1e-6, "filip gsl_fit_multilinear cov55") ;
gsl_test_rel (gsl_vector_get(&diag.vector,6), pow(expected_sd[6],2.0), 1e-6, "filip gsl_fit_multilinear cov66") ;
gsl_test_rel (gsl_vector_get(&diag.vector,7), pow(expected_sd[7],2.0), 1e-6, "filip gsl_fit_multilinear cov77") ;
gsl_test_rel (gsl_vector_get(&diag.vector,8), pow(expected_sd[8],2.0), 1e-6, "filip gsl_fit_multilinear cov88") ;
gsl_test_rel (gsl_vector_get(&diag.vector,9), pow(expected_sd[9],2.0), 1e-6, "filip gsl_fit_multilinear cov99") ;
gsl_test_rel (gsl_vector_get(&diag.vector,10), pow(expected_sd[10],2.0), 1e-6, "filip gsl_fit_multilinear cov1010") ;
gsl_test_rel (chisq, expected_chisq, 1e-7, "filip gsl_fit_multilinear chisq") ;
gsl_vector_free(c);
gsl_matrix_free(cov);
gsl_matrix_free(X);
gsl_multifit_linear_free (work);
}
{
gsl_multifit_linear_workspace * work =
gsl_multifit_linear_alloc (filip_n, filip_p);
gsl_matrix * X = gsl_matrix_alloc (filip_n, filip_p);
gsl_vector_view y = gsl_vector_view_array (filip_y, filip_n);
gsl_vector * w = gsl_vector_alloc (filip_n);
gsl_vector * c = gsl_vector_alloc (filip_p);
gsl_matrix * cov = gsl_matrix_alloc (filip_p, filip_p);
double chisq;
double expected_c[11] = { -1467.48961422980,
-2772.17959193342,
-2316.37108160893,
-1127.97394098372,
-354.478233703349,
-75.1242017393757,
-10.8753180355343,
-1.06221498588947,
-0.670191154593408E-01,
-0.246781078275479E-02,
-0.402962525080404E-04 };
/* computed using GNU Calc */
double expected_cov[11][11] ={ { 7.9269341767252183262588583867942e9, 1.4880416622254098343441063389706e10, 1.2385811858111487905481427591107e10, 6.0210784406215266653697715794241e9, 1.8936652526181982747116667336389e9, 4.0274900618493109653998118587093e8, 5.8685468011819735806180092394606e7, 5.7873451475721689084330083708901e6, 3.6982719848703747920663262917032e5, 1.3834818802741350637527054170891e4, 2.301758578713219280719633494302e2 },
{ 1.4880416622254098334697515488559e10, 2.7955091668548290835529555438088e10, 2.3286604504243362691678565997033e10, 1.132895006796272983689297219686e10, 3.5657281653312473123348357644683e9, 7.5893300392314445528176646366087e8, 1.1066654886143524811964131660002e8, 1.0921285448484575110763947787775e7, 6.9838139975394769253353547606971e5, 2.6143091775349597218939272614126e4, 4.3523386330348588614289505633539e2 },
{ 1.2385811858111487890788272968677e10, 2.3286604504243362677757802422747e10, 1.9412787917766676553608636489674e10, 9.4516246492862131849077729250098e9, 2.9771226694709917550143152097252e9, 6.3413035086730038062129508949859e8, 9.2536164488309401636559552742339e7, 9.1386304643423333815338760248027e6, 5.8479478338916429826337004060941e5, 2.1905933113294737443808429764554e4, 3.6493161325305557266196635180155e2 },
{ 6.0210784406215266545770691532365e9, 1.1328950067962729823273441573365e10, 9.4516246492862131792040001429636e9, 4.6053152992000107509329772255094e9, 1.4517147860312147098138030287038e9, 3.0944988323328589376402579060072e8, 4.5190223822292688669369522708712e7, 4.4660958693678497534529855690752e6, 2.8599340736122198213681258676423e5, 1.0720394998549386596165641244705e4, 1.7870937745661967319298031044424e2 },
{ 1.8936652526181982701620450132636e9, 3.5657281653312473058825073094524e9, 2.9771226694709917514149924058297e9, 1.451714786031214708936087401632e9, 4.5796563896564815123074920050827e8, 9.7693972414561515534525103622773e7, 1.427717861635658545863942948444e7, 1.4120161287735817621354292900338e6, 9.0484361228623960006818614875557e4, 3.394106783764852373199087455398e3, 5.6617406468519495376287407526295e1 },
{ 4.0274900618493109532650887473599e8, 7.589330039231444534478894935778e8, 6.3413035086730037947153564986653e8, 3.09449883233285893390542947998e8, 9.7693972414561515475770399055121e7, 2.0855726248311948992114244257719e7, 3.0501263034740400533872858749566e6, 3.0187475839310308153394428784224e5, 1.9358204633534233524477930175632e4, 7.2662989867560017077361942813911e2, 1.2129002231061036467607394277965e1 },
{ 5.868546801181973559370854830868e7, 1.1066654886143524778548044386795e8, 9.2536164488309401413296494869777e7, 4.5190223822292688587853853162072e7, 1.4277178616356585441556046753562e7, 3.050126303474040051574715592746e6, 4.4639982579046340884744460329946e5, 4.4212093985989836047285007760238e4, 2.8371395028774486687625333589972e3, 1.0656694507620102300567296504381e2, 1.7799982046359973175080475654123e0 },
{ 5.7873451475721688839974153925406e6, 1.0921285448484575071271480643397e7, 9.1386304643423333540728480344578e6, 4.4660958693678497427674903565664e6, 1.4120161287735817596182229182587e6, 3.0187475839310308117812257613082e5, 4.4212093985989836021482392757677e4, 4.3818874017028389517560906916315e3, 2.813828775753142855163154605027e2, 1.0576188138416671883232607188969e1, 1.7676976288918295012452853715408e-1 },
{ 3.6982719848703747742568351456818e5, 6.9838139975394768959780068745979e5, 5.8479478338916429616547638954781e5, 2.8599340736122198128717796825489e5, 9.0484361228623959793493985226792e4, 1.9358204633534233490579641064343e4, 2.8371395028774486654873647731797e3, 2.8138287757531428535592907878017e2, 1.8081118503579798222896804627964e1, 6.8005074291434681866415478598732e-1, 1.1373581557749643543869665860719e-2 },
{ 1.3834818802741350562839757244708e4, 2.614309177534959709397445440919e4, 2.1905933113294737352721470167247e4, 1.0720394998549386558251721913182e4, 3.3941067837648523632905604575131e3, 7.2662989867560016909534954790835e2, 1.0656694507620102282337905013451e2, 1.0576188138416671871337685672492e1, 6.8005074291434681828743281967838e-1, 2.5593857187900736057022477529078e-2, 4.2831487599116264442963102045936e-4 },
{ 2.3017585787132192669801658674163e2, 4.3523386330348588381716460685124e2, 3.6493161325305557094116270974735e2, 1.7870937745661967246233792737255e2, 5.6617406468519495180024059284629e1, 1.2129002231061036433003571679329e1, 1.7799982046359973135014027410646e0, 1.7676976288918294983059118597214e-1, 1.137358155774964353146460100337e-2, 4.283148759911626442000316269063e-4, 7.172253875245080423800933453952e-6 } };
double expected_chisq = 0.795851382172941E-03;
for (i = 0 ; i < filip_n; i++)
{
for (j = 0; j < filip_p; j++)
{
gsl_matrix_set(X, i, j, pow(filip_x[i], j));
}
}
gsl_vector_set_all (w, 1.0);
gsl_multifit_wlinear (X, w, &y.vector, c, cov, &chisq, work);
gsl_test_rel (gsl_vector_get(c,0), expected_c[0], 1e-7, "filip gsl_fit_multilinear c0") ;
gsl_test_rel (gsl_vector_get(c,1), expected_c[1], 1e-7, "filip gsl_fit_multilinear c1") ;
gsl_test_rel (gsl_vector_get(c,2), expected_c[2], 1e-7, "filip gsl_fit_multilinear c2") ;
gsl_test_rel (gsl_vector_get(c,3), expected_c[3], 1e-7, "filip gsl_fit_multilinear c3") ;
gsl_test_rel (gsl_vector_get(c,4), expected_c[4], 1e-7, "filip gsl_fit_multilinear c4") ;
gsl_test_rel (gsl_vector_get(c,5), expected_c[5], 1e-7, "filip gsl_fit_multilinear c5") ;
gsl_test_rel (gsl_vector_get(c,6), expected_c[6], 1e-7, "filip gsl_fit_multilinear c6") ;
gsl_test_rel (gsl_vector_get(c,7), expected_c[7], 1e-7, "filip gsl_fit_multilinear c7") ;
gsl_test_rel (gsl_vector_get(c,8), expected_c[8], 1e-7, "filip gsl_fit_multilinear c8") ;
gsl_test_rel (gsl_vector_get(c,9), expected_c[9], 1e-7, "filip gsl_fit_multilinear c9") ;
gsl_test_rel (gsl_vector_get(c,10), expected_c[10], 1e-7, "filip gsl_fit_multilinear c10") ;
for (i = 0; i < filip_p; i++)
{
for (j = 0; j < filip_p; j++)
{
gsl_test_rel (gsl_matrix_get(cov,i,j), expected_cov[i][j], 1e-6,
"filip gsl_fit_wmultilinear cov(%d,%d)", i, j) ;
}
}
gsl_test_rel (chisq, expected_chisq, 1e-7, "filip gsl_fit_multilinear chisq") ;
gsl_vector_free(w);
gsl_vector_free(c);
gsl_matrix_free(cov);
gsl_matrix_free(X);
gsl_multifit_linear_free (work);
}
}
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;
}
static int
lmniel_iterate(void *vstate, const gsl_vector *swts,
gsl_multifit_function_fdf *fdf, gsl_vector *x,
gsl_vector *f, gsl_vector *dx)
{
int status;
lmniel_state_t *state = (lmniel_state_t *) vstate;
gsl_matrix *J = state->J; /* Jacobian J(x) */
gsl_matrix *A = state->A; /* J^T J */
gsl_vector *rhs = state->rhs; /* -g = -J^T f */
gsl_vector *x_trial = state->x_trial; /* trial x + dx */
gsl_vector *f_trial = state->f_trial; /* trial f(x + dx) */
gsl_vector *diag = state->diag; /* diag(D) */
double dF; /* F(x) - F(x + dx) */
double dL; /* L(0) - L(dx) */
int foundstep = 0; /* found step dx */
/* compute A = J^T J */
status = gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, J, J, 0.0, A);
if (status)
return status;
#if SCALE
lmniel_update_diag(J, diag);
#endif
/* loop until we find an acceptable step dx */
while (!foundstep)
{
/* solve (A + mu*I) dx = g */
status = lmniel_calc_dx(state->mu, A, rhs, dx, state);
if (status)
return status;
/* compute x_trial = x + dx */
lmniel_trial_step(x, dx, x_trial);
/* compute f(x + dx) */
status = gsl_multifit_eval_wf(fdf, x_trial, swts, f_trial);
if (status)
return status;
/* compute dF = F(x) - F(x + dx) */
dF = lmniel_calc_dF(f, f_trial);
/* compute dL = L(0) - L(dx) = dx^T (mu*dx - g) */
dL = lmniel_calc_dL(state->mu, diag, dx, rhs);
/* check that rho = dF/dL > 0 */
if ((dL > 0.0) && (dF >= 0.0))
{
/* reduction in error, step acceptable */
double tmp;
/* update LM parameter mu */
tmp = 2.0 * (dF / dL) - 1.0;
tmp = 1.0 - tmp*tmp*tmp;
state->mu *= GSL_MAX(LM_ONE_THIRD, tmp);
state->nu = 2;
/* compute J <- J(x + dx) */
if (fdf->df)
status = gsl_multifit_eval_wdf(fdf, x_trial, swts, J);
else
status = gsl_multifit_fdfsolver_dif_df(x_trial, swts, fdf, f_trial, J);
if (status)
return status;
/* update x <- x + dx */
gsl_vector_memcpy(x, x_trial);
/* update f <- f(x + dx) */
gsl_vector_memcpy(f, f_trial);
/* compute new rhs = -J^T f */
gsl_blas_dgemv(CblasTrans, -1.0, J, f, 0.0, rhs);
foundstep = 1;
}
else
{
long nu2;
/* step did not reduce error, reject step */
state->mu *= state->nu;
nu2 = state->nu << 1; /* 2*nu */
if (nu2 <= state->nu)
{
gsl_vector_view d = gsl_matrix_diagonal(A);
/*
* nu has wrapped around / overflown, reset mu and nu
* to original values and break to force another iteration
*/
/*GSL_ERROR("nu parameter has overflown", GSL_EOVRFLW);*/
state->nu = 2;
state->mu = state->tau * gsl_vector_max(&d.vector);
break;
}
state->nu = nu2;
}
} /* while (!foundstep) */
return GSL_SUCCESS;
} /* lmniel_iterate() */
void KFKSDS_steady (int *dim, double *sy, double *sZ, double *sT, double *sH,
double *sR, double *sV, double *sQ, double *sa0, double *sP0,
double *tol, int *maxiter, double *ksconvfactor,
double *mll, double *epshat, double *vareps,
double *etahat, double *vareta,
double *sumepsmisc, double *sumetamisc)
{
int i, ip1, n = dim[0], m = dim[2], ir = dim[3], convref, nmconvref, nm1 = n-1;
int irsod = ir * sizeof(double);
//double v[n], f[n], invf[n], vof[n];
std::vector<double> v(n), f(n), invf(n), vof(n);
sumepsmisc[0] = 0.0;
gsl_vector * sum_eta_misc = gsl_vector_calloc(ir);
gsl_vector * etahat_sq = gsl_vector_alloc(ir);
gsl_vector_view Z = gsl_vector_view_array(sZ, m);
gsl_vector * Z_cp = gsl_vector_alloc(m);
gsl_matrix * K = gsl_matrix_alloc(n, m);
gsl_vector_view K_irow;
gsl_matrix_view Q = gsl_matrix_view_array(sQ, m, m);
gsl_matrix_view V = gsl_matrix_view_array(sV, ir, ir);
gsl_matrix_view R = gsl_matrix_view_array(sR, m, ir);
gsl_matrix * r = gsl_matrix_alloc(n + 1, m);
gsl_vector_view r_row_t;
gsl_vector_view r_row_tp1 = gsl_matrix_row(r, n);
gsl_vector_set_zero(&r_row_tp1.vector);
std::vector<gsl_matrix*> L(n);
std::vector<gsl_matrix*> N(n+1);
N.at(n) = gsl_matrix_calloc(m, m);
gsl_vector_view Ndiag;
gsl_vector_view Qdiag = gsl_matrix_diagonal(&Q.matrix);
gsl_vector * Qdiag_msq = gsl_vector_alloc(m);
gsl_vector_memcpy(Qdiag_msq, &Qdiag.vector);
gsl_vector_mul(Qdiag_msq, &Qdiag.vector);
gsl_vector_scale(Qdiag_msq, -1.0);
gsl_vector * sum_vareta = gsl_vector_calloc(m);
KF_steady(dim, sy, sZ, sT, sH,
sR, sV, sQ, sa0, sP0,
mll, &v, &f, &invf, &vof, K, &L, tol, maxiter);
convref = dim[5];
if (convref == -1) {
convref = n;
} else
convref = ceil(convref * ksconvfactor[0]);
nmconvref = n - convref;
gsl_vector_view vaux;
gsl_matrix * Mmm = gsl_matrix_alloc(m, m);
gsl_matrix * ZtZ = gsl_matrix_alloc(m, m);
gsl_matrix_view maux1, maux2;
maux1 = gsl_matrix_view_array(gsl_vector_ptr(&Z.vector, 0), m, 1);
gsl_vector_memcpy(Z_cp, &Z.vector);
maux2 = gsl_matrix_view_array(gsl_vector_ptr(Z_cp, 0), 1, m);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, &maux1.matrix,
&maux2.matrix, 0.0, ZtZ);
gsl_vector * var_eps = gsl_vector_alloc(n);
double msHsq = -1.0 * pow(*sH, 2);
vaux = gsl_vector_view_array(&f[0], n);
gsl_vector_set_all(var_eps, msHsq);
gsl_vector_div(var_eps, &vaux.vector);
gsl_vector_add_constant(var_eps, *sH);
gsl_matrix * eta_hat = gsl_matrix_alloc(n, ir);
gsl_matrix * Mrm = gsl_matrix_alloc(ir, m);
gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, &V.matrix, &R.matrix, 0.0, Mrm);
for (i = n-1; i > -1; i--)
{
ip1 = i + 1;
if (i != n-1) //the case i=n-1 was initialized above
r_row_tp1 = gsl_matrix_row(r, ip1);
r_row_t = gsl_matrix_row(r, i);
gsl_blas_dgemv(CblasTrans, 1.0, L.at(i), &r_row_tp1.vector,
0.0, &r_row_t.vector);
gsl_vector_memcpy(Z_cp, &Z.vector);
gsl_vector_scale(Z_cp, vof[i]);
gsl_vector_add(&r_row_t.vector, Z_cp);
N.at(i) = gsl_matrix_alloc(m, m);
if (i < convref || i > nmconvref)
{
gsl_matrix_memcpy(N.at(i), ZtZ);
gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, L.at(i), N.at(ip1), 0.0, Mmm);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm, L.at(i), invf[i], N.at(i));
} else {
gsl_matrix_memcpy(N.at(i), N.at(ip1));
}
if (dim[6] == 0 || dim[6] == 1)
{
if (i < convref || i == nm1) {
K_irow = gsl_matrix_row(K, i);
}
gsl_blas_ddot(&K_irow.vector, &r_row_tp1.vector, &epshat[i]);
epshat[i] -= vof[i];
epshat[i] *= -*sH;
if (i < convref || i > nmconvref)
{
maux1 = gsl_matrix_view_array(gsl_vector_ptr(&K_irow.vector, 0), 1, m);
maux2 = gsl_matrix_view_array(gsl_vector_ptr(Z_cp, 0), 1, m);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, &maux1.matrix, N.at(ip1),
0.0, &maux2.matrix);
vaux = gsl_vector_view_array(gsl_vector_ptr(var_eps, i), 1);
gsl_blas_dgemv(CblasNoTrans, msHsq, &maux2.matrix, &K_irow.vector,
1.0, &vaux.vector);
vareps[i] = gsl_vector_get(&vaux.vector, 0);
} else {
vareps[i] = vareps[ip1];
}
sumepsmisc[0] += epshat[i] * epshat[i] + vareps[i];
}
if (dim[6] == 0 || dim[6] == 2)
{
vaux = gsl_matrix_row(eta_hat, i);
gsl_blas_dgemv(CblasNoTrans, 1.0, Mrm, &r_row_tp1.vector,
0.0, &vaux.vector);
memcpy(&etahat[i*ir], (&vaux.vector)->data, irsod);
if (i != n-1)
{
gsl_vector_memcpy(etahat_sq, &vaux.vector);
gsl_vector_mul(etahat_sq, etahat_sq);
gsl_vector_add(sum_eta_misc, etahat_sq);
}
if (i != n-1)
{
if (i < convref || i > nmconvref)
{
Ndiag = gsl_matrix_diagonal(N.at(ip1));
gsl_vector_memcpy(Z_cp, &Ndiag.vector);
gsl_vector_mul(Z_cp, Qdiag_msq);
gsl_vector_add(Z_cp, &Qdiag.vector);
gsl_vector_set_zero(sum_vareta);
gsl_vector_add(sum_vareta, Z_cp);
}
gsl_blas_dgemv(CblasTrans, 1.0, &R.matrix, sum_vareta, 1.0, sum_eta_misc);
}
}
gsl_matrix_free(L.at(i));
gsl_matrix_free(N.at(ip1));
}
gsl_matrix_free(N.at(0));
if (dim[6] == 0 || dim[6] == 2)
{
memcpy(&sumetamisc[0], sum_eta_misc->data, irsod);
}
gsl_vector_free(Z_cp);
gsl_vector_free(var_eps);
gsl_vector_free(Qdiag_msq);
gsl_vector_free(sum_vareta);
gsl_vector_free(sum_eta_misc);
gsl_vector_free(etahat_sq);
gsl_matrix_free(eta_hat);
gsl_matrix_free(Mrm);
gsl_matrix_free(r);
gsl_matrix_free(K);
gsl_matrix_free(ZtZ);
gsl_matrix_free(Mmm);
}
void
test_longley ()
{
size_t i, j;
{
gsl_multifit_linear_workspace * work =
gsl_multifit_linear_alloc (longley_n, longley_p);
gsl_matrix_view X = gsl_matrix_view_array (longley_x, longley_n, longley_p);
gsl_vector_view y = gsl_vector_view_array (longley_y, longley_n);
gsl_vector * c = gsl_vector_alloc (longley_p);
gsl_matrix * cov = gsl_matrix_alloc (longley_p, longley_p);
gsl_vector_view diag;
double chisq;
double expected_c[7] = { -3482258.63459582,
15.0618722713733,
-0.358191792925910E-01,
-2.02022980381683,
-1.03322686717359,
-0.511041056535807E-01,
1829.15146461355 };
double expected_sd[7] = { 890420.383607373,
84.9149257747669,
0.334910077722432E-01,
0.488399681651699,
0.214274163161675,
0.226073200069370,
455.478499142212 } ;
double expected_chisq = 836424.055505915;
gsl_multifit_linear (&X.matrix, &y.vector, c, cov, &chisq, work);
gsl_test_rel (gsl_vector_get(c,0), expected_c[0], 1e-10, "longley gsl_fit_multilinear c0") ;
gsl_test_rel (gsl_vector_get(c,1), expected_c[1], 1e-10, "longley gsl_fit_multilinear c1") ;
gsl_test_rel (gsl_vector_get(c,2), expected_c[2], 1e-10, "longley gsl_fit_multilinear c2") ;
gsl_test_rel (gsl_vector_get(c,3), expected_c[3], 1e-10, "longley gsl_fit_multilinear c3") ;
gsl_test_rel (gsl_vector_get(c,4), expected_c[4], 1e-10, "longley gsl_fit_multilinear c4") ;
gsl_test_rel (gsl_vector_get(c,5), expected_c[5], 1e-10, "longley gsl_fit_multilinear c5") ;
gsl_test_rel (gsl_vector_get(c,6), expected_c[6], 1e-10, "longley gsl_fit_multilinear c6") ;
diag = gsl_matrix_diagonal (cov);
gsl_test_rel (gsl_vector_get(&diag.vector,0), pow(expected_sd[0],2.0), 1e-10, "longley gsl_fit_multilinear cov00") ;
gsl_test_rel (gsl_vector_get(&diag.vector,1), pow(expected_sd[1],2.0), 1e-10, "longley gsl_fit_multilinear cov11") ;
gsl_test_rel (gsl_vector_get(&diag.vector,2), pow(expected_sd[2],2.0), 1e-10, "longley gsl_fit_multilinear cov22") ;
gsl_test_rel (gsl_vector_get(&diag.vector,3), pow(expected_sd[3],2.0), 1e-10, "longley gsl_fit_multilinear cov33") ;
gsl_test_rel (gsl_vector_get(&diag.vector,4), pow(expected_sd[4],2.0), 1e-10, "longley gsl_fit_multilinear cov44") ;
gsl_test_rel (gsl_vector_get(&diag.vector,5), pow(expected_sd[5],2.0), 1e-10, "longley gsl_fit_multilinear cov55") ;
gsl_test_rel (gsl_vector_get(&diag.vector,6), pow(expected_sd[6],2.0), 1e-10, "longley gsl_fit_multilinear cov66") ;
gsl_test_rel (chisq, expected_chisq, 1e-10, "longley gsl_fit_multilinear chisq") ;
gsl_vector_free(c);
gsl_matrix_free(cov);
gsl_multifit_linear_free (work);
}
{
gsl_multifit_linear_workspace * work =
gsl_multifit_linear_alloc (longley_n, longley_p);
gsl_matrix_view X = gsl_matrix_view_array (longley_x, longley_n, longley_p);
gsl_vector_view y = gsl_vector_view_array (longley_y, longley_n);
gsl_vector * w = gsl_vector_alloc (longley_n);
gsl_vector * c = gsl_vector_alloc (longley_p);
gsl_matrix * cov = gsl_matrix_alloc (longley_p, longley_p);
double chisq;
double expected_c[7] = { -3482258.63459582,
15.0618722713733,
-0.358191792925910E-01,
-2.02022980381683,
-1.03322686717359,
-0.511041056535807E-01,
1829.15146461355 };
double expected_cov[7][7] = { { 8531122.56783558,
-166.727799925578, 0.261873708176346, 3.91188317230983,
1.1285582054705, -0.889550869422687, -4362.58709870581},
{-166.727799925578, 0.0775861253030891, -1.98725210399982e-05,
-0.000247667096727256, -6.82911920718824e-05, 0.000136160797527761,
0.0775255245956248},
{0.261873708176346, -1.98725210399982e-05, 1.20690316701888e-08,
1.66429546772984e-07, 3.61843600487847e-08, -6.78805814483582e-08,
-0.00013158719037715},
{3.91188317230983, -0.000247667096727256, 1.66429546772984e-07,
2.56665052544717e-06, 6.96541409215597e-07, -9.00858307771567e-07,
-0.00197260370663974},
{1.1285582054705, -6.82911920718824e-05, 3.61843600487847e-08,
6.96541409215597e-07, 4.94032602583969e-07, -9.8469143760973e-08,
-0.000576921112208274},
{-0.889550869422687, 0.000136160797527761, -6.78805814483582e-08,
-9.00858307771567e-07, -9.8469143760973e-08, 5.49938542664952e-07,
0.000430074434198215},
{-4362.58709870581, 0.0775255245956248, -0.00013158719037715,
-0.00197260370663974, -0.000576921112208274, 0.000430074434198215,
2.23229587481535 }} ;
double expected_chisq = 836424.055505915;
gsl_vector_set_all (w, 1.0);
gsl_multifit_wlinear (&X.matrix, w, &y.vector, c, cov, &chisq, work);
gsl_test_rel (gsl_vector_get(c,0), expected_c[0], 1e-10, "longley gsl_fit_wmultilinear c0") ;
gsl_test_rel (gsl_vector_get(c,1), expected_c[1], 1e-10, "longley gsl_fit_wmultilinear c1") ;
gsl_test_rel (gsl_vector_get(c,2), expected_c[2], 1e-10, "longley gsl_fit_wmultilinear c2") ;
gsl_test_rel (gsl_vector_get(c,3), expected_c[3], 1e-10, "longley gsl_fit_wmultilinear c3") ;
gsl_test_rel (gsl_vector_get(c,4), expected_c[4], 1e-10, "longley gsl_fit_wmultilinear c4") ;
gsl_test_rel (gsl_vector_get(c,5), expected_c[5], 1e-10, "longley gsl_fit_wmultilinear c5") ;
gsl_test_rel (gsl_vector_get(c,6), expected_c[6], 1e-10, "longley gsl_fit_wmultilinear c6") ;
for (i = 0; i < longley_p; i++)
{
for (j = 0; j < longley_p; j++)
{
gsl_test_rel (gsl_matrix_get(cov,i,j), expected_cov[i][j], 1e-7,
"longley gsl_fit_wmultilinear cov(%d,%d)", i, j) ;
}
}
gsl_test_rel (chisq, expected_chisq, 1e-10, "longley gsl_fit_wmultilinear chisq") ;
gsl_vector_free(w);
gsl_vector_free(c);
gsl_matrix_free(cov);
gsl_multifit_linear_free (work);
}
}
gsl_matrix* diag_alloc(gsl_vector* X){
gsl_matrix* mat = gsl_matrix_calloc(X->size, X->size);
gsl_vector_view diag = gsl_matrix_diagonal(mat);
gsl_vector_memcpy(&diag.vector, X);
return mat;
}
static void
test_fdfridge(const gsl_multifit_fdfsolver_type * T, const double xtol,
const double gtol, const double ftol,
const double epsrel, const double x0_scale,
test_fdf_problem *problem, const double *wts)
{
gsl_multifit_function_fdf *fdf = problem->fdf;
const size_t n = fdf->n;
const size_t p = fdf->p;
const size_t max_iter = 1500;
gsl_vector *x0 = gsl_vector_alloc(p);
gsl_vector_view x0v = gsl_vector_view_array(problem->x0, p);
gsl_multifit_fdfridge *w = gsl_multifit_fdfridge_alloc (T, n, p);
const char *pname = problem->name;
char sname[2048];
int status, info;
double lambda = 0.0;
sprintf(sname, "ridge/%s", gsl_multifit_fdfridge_name(w));
/* scale starting point x0 */
gsl_vector_memcpy(x0, &x0v.vector);
test_scale_x0(x0, x0_scale);
/* test undamped case with lambda = 0 */
if (wts)
{
gsl_vector_const_view wv = gsl_vector_const_view_array(wts, n);
gsl_multifit_fdfridge_wset(w, fdf, x0, lambda, &wv.vector);
}
else
gsl_multifit_fdfridge_set(w, fdf, x0, lambda);
status = gsl_multifit_fdfridge_driver(w, max_iter, xtol, gtol,
ftol, &info);
gsl_test(status, "%s/%s did not converge, status=%s",
sname, pname, gsl_strerror(status));
/* check solution */
test_fdf_checksol(sname, pname, epsrel, w->s, problem);
/* test for self consisent solution with L = \lambda I */
{
const double eps = 1.0e-10;
gsl_matrix *L = gsl_matrix_calloc(p, p);
gsl_vector_view diag = gsl_matrix_diagonal(L);
gsl_multifit_fdfridge *w2 = gsl_multifit_fdfridge_alloc (T, n, p);
gsl_vector *y0 = gsl_vector_alloc(p);
size_t i;
/* pick some value for lambda and set L = \lambda I */
lambda = 5.0;
gsl_vector_set_all(&diag.vector, lambda);
/* scale initial vector */
gsl_vector_memcpy(x0, &x0v.vector);
test_scale_x0(x0, x0_scale);
gsl_vector_memcpy(y0, x0);
if (wts)
{
gsl_vector_const_view wv = gsl_vector_const_view_array(wts, n);
gsl_multifit_fdfridge_wset(w, fdf, x0, lambda, &wv.vector);
gsl_multifit_fdfridge_wset3(w2, fdf, y0, L, &wv.vector);
}
else
{
gsl_multifit_fdfridge_set(w, fdf, x0, lambda);
gsl_multifit_fdfridge_set3(w2, fdf, y0, L);
}
/* solve with scalar lambda routine */
status = gsl_multifit_fdfridge_driver(w, max_iter, xtol, gtol,
ftol, &info);
gsl_test(status, "%s/lambda/%s did not converge, status=%s",
sname, pname, gsl_strerror(status));
/* solve with general matrix routine */
status = gsl_multifit_fdfridge_driver(w2, max_iter, xtol, gtol,
ftol, &info);
gsl_test(status, "%s/L/%s did not converge, status=%s",
sname, pname, gsl_strerror(status));
/* test x = y */
for (i = 0; i < p; ++i)
{
double xi = gsl_vector_get(w->s->x, i);
double yi = gsl_vector_get(w2->s->x, i);
if (fabs(xi) < eps)
{
gsl_test_abs(yi, xi, eps, "%s/%s ridge lambda=%g i="F_ZU,
sname, pname, lambda, i);
}
else
{
gsl_test_rel(yi, xi, eps, "%s/%s ridge lambda=%g i="F_ZU,
sname, pname, lambda, i);
}
}
gsl_matrix_free(L);
gsl_vector_free(y0);
gsl_multifit_fdfridge_free(w2);
}
gsl_multifit_fdfridge_free(w);
gsl_vector_free(x0);
}
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;
}
Vector Matrix::diagonalVector () {
return Vector( gsl_matrix_diagonal( &matrix ) );
}
void
test_pontius ()
{
size_t i, j;
gsl_multifit_linear_workspace * work =
gsl_multifit_linear_alloc (pontius_n, pontius_p);
gsl_multifit_robust_workspace * work_rob =
gsl_multifit_robust_alloc (gsl_multifit_robust_ols, pontius_n, pontius_p);
gsl_matrix * X = gsl_matrix_alloc (pontius_n, pontius_p);
gsl_vector_view y = gsl_vector_view_array (pontius_y, pontius_n);
gsl_vector * c = gsl_vector_alloc (pontius_p);
gsl_vector * r = gsl_vector_alloc (pontius_n);
gsl_matrix * cov = gsl_matrix_alloc (pontius_p, pontius_p);
double chisq, chisq_res;
double expected_c[3] = { 0.673565789473684E-03,
0.732059160401003E-06,
-0.316081871345029E-14};
double expected_sd[3] = { 0.107938612033077E-03,
0.157817399981659E-09,
0.486652849992036E-16 };
double expected_chisq = 0.155761768796992E-05;
gsl_vector_view diag = gsl_matrix_diagonal (cov);
gsl_vector_view exp_c = gsl_vector_view_array(expected_c, pontius_p);
gsl_vector_view exp_sd = gsl_vector_view_array(expected_sd, pontius_p);
for (i = 0 ; i < pontius_n; i++)
{
for (j = 0; j < pontius_p; j++)
{
gsl_matrix_set(X, i, j, pow(pontius_x[i], j));
}
}
/* test unweighted least squares */
gsl_multifit_linear (X, &y.vector, c, cov, &chisq, work);
gsl_multifit_linear_residuals(X, &y.vector, c, r);
gsl_blas_ddot(r, r, &chisq_res);
test_pontius_results("pontius gsl_multifit_linear",
c, &exp_c.vector,
&diag.vector, &exp_sd.vector,
chisq, chisq_res, expected_chisq);
/* test robust least squares */
gsl_multifit_robust (X, &y.vector, c, cov, work_rob);
test_pontius_results("pontius gsl_multifit_robust",
c, &exp_c.vector,
&diag.vector, &exp_sd.vector,
1.0, 1.0, 1.0);
/* test weighted least squares */
{
gsl_vector * w = gsl_vector_alloc (pontius_n);
double expected_cov[3][3] ={
{2.76754385964916e-01 , -3.59649122807024e-07, 9.74658869395731e-14},
{-3.59649122807024e-07, 5.91630591630603e-13, -1.77210703526497e-19},
{9.74658869395731e-14, -1.77210703526497e-19, 5.62573661988878e-26} };
gsl_vector_set_all (w, 1.0);
gsl_multifit_wlinear (X, w, &y.vector, c, cov, &chisq, work);
gsl_multifit_linear_residuals(X, &y.vector, c, r);
gsl_blas_ddot(r, r, &chisq_res);
test_pontius_results("pontius gsl_multifit_wlinear",
c, &exp_c.vector,
NULL, NULL,
chisq, chisq_res, expected_chisq);
for (i = 0; i < pontius_p; i++)
{
for (j = 0; j < pontius_p; j++)
{
gsl_test_rel (gsl_matrix_get(cov,i,j), expected_cov[i][j], 1e-10,
"pontius gsl_multifit_wlinear cov(%d,%d)", i, j) ;
}
}
gsl_vector_free(w);
}
gsl_vector_free(c);
gsl_vector_free(r);
gsl_matrix_free(cov);
gsl_matrix_free(X);
gsl_multifit_linear_free (work);
gsl_multifit_robust_free (work_rob);
}
int mvn(gsl_rng * rng, const gsl_vector * mean, gsl_matrix * covar, gsl_vector * ANS)
{
int i;
size_t n = mean->size;
/* Calculate eigenvalues and eigenvectors of covar matrix */
gsl_vector *eval = gsl_vector_alloc (n);
gsl_matrix *evec = gsl_matrix_alloc (n, n);
gsl_eigen_symmv_workspace * w = gsl_eigen_symmv_alloc (n);
gsl_eigen_symmv (covar, eval, evec, w);
gsl_eigen_symmv_free (w);
// gsl_eigen_symmv_sort (eval, evec, GSL_EIGEN_SORT_ABS_DESC);
/* Setup for: evec * matrix(diag(eval)) * transpose(evec) */
gsl_matrix *eval_mx = gsl_matrix_calloc (n, n);
gsl_matrix * x_M = gsl_matrix_alloc (n,n);
gsl_matrix * x_M_x = gsl_matrix_alloc (n,n);
gsl_vector_view diagonal = gsl_matrix_diagonal(eval_mx);
gsl_vector_memcpy(&diagonal.vector, eval);
for(i=0;i<n;i++)
{
gsl_vector_set( &diagonal.vector,
i,
sqrt( gsl_vector_get(&diagonal.vector, i) )
);
}
/* evec * matrix(diag(eval)) * transpose(evec) */
// gsl_blas_dsymm (CblasLeft, CblasUpper,
// 1.0, evec, eval_mx, 0.0, x_M);
gsl_blas_dgemm (CblasNoTrans, CblasNoTrans,
1.0, evec, eval_mx, 0.0, x_M);
gsl_blas_dgemm (CblasNoTrans, CblasTrans,
1.0, x_M, evec, 0.0, x_M_x);
gsl_matrix_free(x_M);
gsl_matrix_free(eval_mx);
gsl_matrix_free(evec);
gsl_vector_free(eval);
gsl_vector * rnorms = gsl_vector_alloc(n);
for(i=0;i<n;i++)
{
gsl_vector_set
( rnorms, i,
gsl_ran_gaussian_ziggurat(rng, 1)
);
}
gsl_blas_dgemv( CblasTrans, 1.0, x_M_x, rnorms, 0, ANS);
gsl_vector_add(ANS, mean);
gsl_matrix_free(x_M_x);
gsl_vector_free(rnorms);
return 0;
/* answer provided through pass by reference */
}
