int
lls_lcurve(gsl_vector *reg_param, gsl_vector *rho, gsl_vector *eta,
lls_workspace *w)
{
const size_t N = rho->size; /* number of points on L-curve */
if (N != reg_param->size)
{
GSL_ERROR("size of reg_param and rho do not match", GSL_EBADLEN);
}
else if (N != eta->size)
{
GSL_ERROR("size of eta and rho do not match", GSL_EBADLEN);
}
else
{
int s;
double smax, smin;
size_t i;
/* compute eigenvalues of A^T W A */
gsl_matrix_transpose_memcpy(w->work_A, w->ATA);
s = gsl_eigen_symm(w->work_A, w->eval, w->eigen_p);
if (s)
return s;
/* find largest and smallest eigenvalues */
gsl_vector_minmax(w->eval, &smin, &smax);
/* singular values are square roots of eigenvalues */
smax = sqrt(smax);
if (smin > GSL_DBL_EPSILON)
smin = sqrt(fabs(smin));
gsl_multifit_linear_lreg(smin, smax, reg_param);
for (i = 0; i < N; ++i)
{
double r2;
double lambda = gsl_vector_get(reg_param, i);
lls_solve(lambda, w->c, w);
/* store ||c|| */
gsl_vector_set(eta, i, gsl_blas_dnrm2(w->c));
/* compute: A^T A c - 2 A^T y */
gsl_vector_memcpy(w->work_b, w->ATb);
gsl_blas_dsymv(CblasUpper, 1.0, w->ATA, w->c, -2.0, w->work_b);
/* compute: c^T A^T A c - 2 c^T A^T y */
gsl_blas_ddot(w->c, w->work_b, &r2);
r2 += w->bTb;
gsl_vector_set(rho, i, sqrt(r2));
}
return GSL_SUCCESS;
}
} /* lls_lcurve() */
int
gsl_multifit_linear_lcurve (const gsl_vector * y,
gsl_vector * reg_param,
gsl_vector * rho, gsl_vector * eta,
gsl_multifit_linear_workspace * work)
{
const size_t n = y->size;
const size_t N = rho->size; /* number of points on L-curve */
if (n != work->n)
{
GSL_ERROR("y vector does not match workspace", GSL_EBADLEN);
}
else if (N < 3)
{
GSL_ERROR ("at least 3 points are needed for L-curve analysis",
GSL_EBADLEN);
}
else if (N != eta->size)
{
GSL_ERROR ("size of rho and eta vectors do not match",
GSL_EBADLEN);
}
else if (reg_param->size != eta->size)
{
GSL_ERROR ("size of reg_param and eta vectors do not match",
GSL_EBADLEN);
}
else
{
int status = GSL_SUCCESS;
const size_t p = work->p;
size_t i, j;
gsl_matrix_view A = gsl_matrix_submatrix(work->A, 0, 0, n, p);
gsl_vector_view S = gsl_vector_subvector(work->S, 0, p);
gsl_vector_view xt = gsl_vector_subvector(work->xt, 0, p);
gsl_vector_view workp = gsl_matrix_subcolumn(work->QSI, 0, 0, p);
gsl_vector_view workp2 = gsl_vector_subvector(work->D, 0, p); /* D isn't used for regularized problems */
const double smax = gsl_vector_get(&S.vector, 0);
const double smin = gsl_vector_get(&S.vector, p - 1);
double dr; /* residual error from projection */
double normy = gsl_blas_dnrm2(y);
double normUTy;
/* compute projection xt = U^T y */
gsl_blas_dgemv (CblasTrans, 1.0, &A.matrix, y, 0.0, &xt.vector);
normUTy = gsl_blas_dnrm2(&xt.vector);
dr = normy*normy - normUTy*normUTy;
/* calculate regularization parameters */
gsl_multifit_linear_lreg(smin, smax, reg_param);
for (i = 0; i < N; ++i)
{
double lambda = gsl_vector_get(reg_param, i);
double lambda_sq = lambda * lambda;
for (j = 0; j < p; ++j)
{
double sj = gsl_vector_get(&S.vector, j);
double xtj = gsl_vector_get(&xt.vector, j);
double f = sj / (sj*sj + lambda_sq);
gsl_vector_set(&workp.vector, j, f * xtj);
gsl_vector_set(&workp2.vector, j, (1.0 - sj*f) * xtj);
}
gsl_vector_set(eta, i, gsl_blas_dnrm2(&workp.vector));
gsl_vector_set(rho, i, gsl_blas_dnrm2(&workp2.vector));
}
if (n > p && dr > 0.0)
{
/* add correction to residual norm (see eqs 6-7 of [1]) */
for (i = 0; i < N; ++i)
{
double rhoi = gsl_vector_get(rho, i);
double *ptr = gsl_vector_ptr(rho, i);
*ptr = sqrt(rhoi*rhoi + dr);
}
}
/* restore D to identity matrix */
gsl_vector_set_all(work->D, 1.0);
return status;
}
} /* gsl_multifit_linear_lcurve() */
