int
gsl_linalg_QR_svx (const gsl_matrix * QR, const gsl_vector * tau, gsl_vector * x)
{
if (QR->size1 != QR->size2)
{
GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
}
else if (QR->size1 != x->size)
{
GSL_ERROR ("matrix size must match x/rhs size", GSL_EBADLEN);
}
else
{
/* compute rhs = Q^T b */
gsl_linalg_QR_QTvec (QR, tau, x);
/* Solve R x = rhs, storing x in-place */
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_QRPT_svx (const gsl_matrix * QR,
const gsl_vector * tau,
const gsl_permutation * p,
gsl_vector * x)
{
if (QR->size1 != QR->size2)
{
GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
}
else if (QR->size1 != p->size)
{
GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN);
}
else if (QR->size2 != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else
{
/* compute sol = Q^T b */
gsl_linalg_QR_QTvec (QR, tau, x);
/* Solve R x = sol, storing x inplace in sol */
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);
gsl_permute_vector_inverse (p, x);
return GSL_SUCCESS;
}
}
CAMLprim value ml_gsl_linalg_QR_QTvec(value QR, value TAU, value V)
{
_DECLARE_MATRIX(QR);
_DECLARE_VECTOR2(TAU, V);
_CONVERT_MATRIX(QR);
_CONVERT_VECTOR2(TAU, V);
gsl_linalg_QR_QTvec(&m_QR, &v_TAU, &v_V);
return Val_unit;
}
int
gsl_linalg_COD_lssolve (const gsl_matrix * QRZ, const gsl_vector * tau_Q, const gsl_vector * tau_Z,
const gsl_permutation * perm, const size_t rank, const gsl_vector * b,
gsl_vector * x, gsl_vector * residual)
{
const size_t M = QRZ->size1;
const size_t N = QRZ->size2;
if (M < N)
{
GSL_ERROR ("QRZ matrix must have M>=N", GSL_EBADLEN);
}
else if (M != b->size)
{
GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
}
else if (rank > GSL_MIN (M, N))
{
GSL_ERROR ("rank must be <= MIN(M,N)", GSL_EBADLEN);
}
else if (N != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else if (M != residual->size)
{
GSL_ERROR ("matrix size must match residual size", GSL_EBADLEN);
}
else
{
gsl_matrix_const_view R11 = gsl_matrix_const_submatrix (QRZ, 0, 0, rank, rank);
gsl_vector_view QTb1 = gsl_vector_subvector(residual, 0, rank);
gsl_vector_view x1 = gsl_vector_subvector(x, 0, rank);
gsl_vector_set_zero(x);
/* compute residual = Q^T b */
gsl_vector_memcpy(residual, b);
gsl_linalg_QR_QTvec (QRZ, tau_Q, residual);
/* solve x1 := R11^{-1} (Q^T b)(1:r) */
gsl_vector_memcpy(&(x1.vector), &(QTb1.vector));
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &(R11.matrix), &(x1.vector));
/* compute Z^T ( R11^{-1} x1; 0 ) */
cod_householder_ZTvec(QRZ, tau_Z, rank, x);
/* compute x = P Z^T ( R11^{-1} x1; 0 ) */
gsl_permute_vector_inverse(perm, x);
/* compute residual = b - A x = Q (Q^T b - R [ R11^{-1} x1; 0 ]) */
gsl_vector_set_zero(&(QTb1.vector));
gsl_linalg_QR_Qvec(QRZ, tau_Q, residual);
return GSL_SUCCESS;
}
}
int
gsl_linalg_QRPT_lssolve2 (const gsl_matrix * QR, const gsl_vector * tau, const gsl_permutation * p,
const gsl_vector * b, const size_t rank, gsl_vector * x, gsl_vector * residual)
{
const size_t M = QR->size1;
const size_t N = QR->size2;
if (M < N)
{
GSL_ERROR ("QR matrix must have M>=N", GSL_EBADLEN);
}
else if (M != b->size)
{
GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
}
else if (rank == 0 || rank > N)
{
GSL_ERROR ("rank must have 0 < rank <= N", GSL_EBADLEN);
}
else if (N != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else if (M != residual->size)
{
GSL_ERROR ("matrix size must match residual size", GSL_EBADLEN);
}
else
{
gsl_matrix_const_view R11 = gsl_matrix_const_submatrix (QR, 0, 0, rank, rank);
gsl_vector_view QTb1 = gsl_vector_subvector(residual, 0, rank);
gsl_vector_view x1 = gsl_vector_subvector(x, 0, rank);
size_t i;
/* compute work = Q^T b */
gsl_vector_memcpy(residual, b);
gsl_linalg_QR_QTvec (QR, tau, residual);
/* solve R_{11} x(1:r) = [Q^T b](1:r) */
gsl_vector_memcpy(&(x1.vector), &(QTb1.vector));
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, &(R11.matrix), &(x1.vector));
/* x(r+1:N) = 0 */
for (i = rank; i < N; ++i)
gsl_vector_set(x, i, 0.0);
/* compute x = P y */
gsl_permute_vector_inverse (p, x);
/* compute residual = b - A x = Q (Q^T b - R x) */
gsl_vector_set_zero(&(QTb1.vector));
gsl_linalg_QR_Qvec(QR, tau, residual);
return GSL_SUCCESS;
}
}
/*same as above but with transpose for q; i.e QtS and not QS */
inline void qr_qtmproduct(double* a, double* tau,
double* s, int m,int n,int p){
gsl_matrix_view av=gsl_matrix_view_array(a,m,n);
gsl_matrix_view sv=gsl_matrix_view_array(s,m,p);
int d;
if (m<n) d=m; else d=n;
gsl_vector_view tv=gsl_vector_view_array(tau,d);
int i;
for (i=0;i<p;i++){
gsl_vector_view scv=gsl_matrix_column(&sv.matrix,i);
gsl_linalg_QR_QTvec(&av.matrix,&tv.vector,&scv.vector);
}
}
void Vector::multQ ( const Vector& tau, const Matrix& qr, const bool transposeQ ) {
const size_t
rows = qr.countRows(),
cols = qr.countColumns();
assert( cols <= rows );
if ( 0 == cols ) {
assert( rows == countDimensions() );
// no operation for 0-dimensional space for matrix R means identity
} else if ( transposeQ ) {
gsl_linalg_QR_QTvec ( &qr.matrix, &tau.vector, &vector );
} else {
gsl_linalg_QR_Qvec ( &qr.matrix, &tau.vector, &vector );
}
}
int
gsl_linalg_QR_lssolve (const gsl_matrix * QR, const gsl_vector * tau, const gsl_vector * b, gsl_vector * x, gsl_vector * residual)
{
const size_t M = QR->size1;
const size_t N = QR->size2;
if (M < N)
{
GSL_ERROR ("QR matrix must have M>=N", GSL_EBADLEN);
}
else if (M != b->size)
{
GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
}
else if (N != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else if (M != residual->size)
{
GSL_ERROR ("matrix size must match residual size", GSL_EBADLEN);
}
else
{
gsl_matrix_const_view R = gsl_matrix_const_submatrix (QR, 0, 0, N, N);
gsl_vector_view c = gsl_vector_subvector(residual, 0, N);
gsl_vector_memcpy(residual, b);
/* compute rhs = Q^T b */
gsl_linalg_QR_QTvec (QR, tau, residual);
/* Solve R x = rhs */
gsl_vector_memcpy(x, &(c.vector));
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, &(R.matrix), x);
/* Compute residual = b - A x = Q (Q^T b - R x) */
gsl_vector_set_zero(&(c.vector));
gsl_linalg_QR_Qvec(QR, tau, residual);
return GSL_SUCCESS;
}
}
static int
iterate (void *vstate, gsl_multifit_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_matrix * J, gsl_vector * dx, int scale)
{
lmder_state_t *state = (lmder_state_t *) vstate;
gsl_matrix *r = state->r;
gsl_vector *tau = state->tau;
gsl_vector *diag = state->diag;
gsl_vector *qtf = state->qtf;
gsl_vector *x_trial = state->x_trial;
gsl_vector *f_trial = state->f_trial;
gsl_vector *rptdx = state->rptdx;
gsl_vector *newton = state->newton;
gsl_vector *gradient = state->gradient;
gsl_vector *sdiag = state->sdiag;
gsl_vector *w = state->w;
gsl_vector *work1 = state->work1;
gsl_permutation *perm = state->perm;
double prered, actred;
double pnorm, fnorm1, fnorm1p, gnorm;
double ratio;
double dirder;
int iter = 0;
double p1 = 0.1, p25 = 0.25, p5 = 0.5, p75 = 0.75, p0001 = 0.0001;
if (state->fnorm == 0.0)
{
return GSL_SUCCESS;
}
/* Compute qtf = Q^T f */
gsl_vector_memcpy (qtf, f);
gsl_linalg_QR_QTvec (r, tau, qtf);
/* Compute norm of scaled gradient */
compute_gradient_direction (r, perm, qtf, diag, gradient);
{
size_t iamax = gsl_blas_idamax (gradient);
gnorm = fabs(gsl_vector_get (gradient, iamax) / state->fnorm);
}
/* Determine the Levenberg-Marquardt parameter */
lm_iteration:
iter++ ;
{
int status = lmpar (r, perm, qtf, diag, state->delta, &(state->par), newton, gradient, sdiag, dx, w);
if (status)
return status;
}
/* Take a trial step */
gsl_vector_scale (dx, -1.0); /* reverse the step to go downhill */
compute_trial_step (x, dx, state->x_trial);
pnorm = scaled_enorm (diag, dx);
if (state->iter == 1)
{
if (pnorm < state->delta)
{
#ifdef DEBUG
printf("set delta = pnorm = %g\n" , pnorm);
#endif
state->delta = pnorm;
}
}
/* Evaluate function at x + p */
/* return immediately if evaluation raised error */
{
int status = GSL_MULTIFIT_FN_EVAL_F (fdf, x_trial, f_trial);
if (status)
return status;
}
fnorm1 = enorm (f_trial);
/* Compute the scaled actual reduction */
actred = compute_actual_reduction (state->fnorm, fnorm1);
#ifdef DEBUG
printf("lmiterate: fnorm = %g fnorm1 = %g actred = %g\n", state->fnorm, fnorm1, actred);
printf("r = "); gsl_matrix_fprintf(stdout, r, "%g");
printf("perm = "); gsl_permutation_fprintf(stdout, perm, "%d");
printf("dx = "); gsl_vector_fprintf(stdout, dx, "%g");
#endif
/* Compute rptdx = R P^T dx, noting that |J dx| = |R P^T dx| */
compute_rptdx (r, perm, dx, rptdx);
#ifdef DEBUG
printf("rptdx = "); gsl_vector_fprintf(stdout, rptdx, "%g");
#endif
fnorm1p = enorm (rptdx);
/* Compute the scaled predicted reduction = |J dx|^2 + 2 par |D dx|^2 */
{
double t1 = fnorm1p / state->fnorm;
double t2 = (sqrt(state->par) * pnorm) / state->fnorm;
prered = t1 * t1 + t2 * t2 / p5;
dirder = -(t1 * t1 + t2 * t2);
}
/* compute the ratio of the actual to predicted reduction */
if (prered > 0)
{
ratio = actred / prered;
}
else
{
ratio = 0;
}
#ifdef DEBUG
printf("lmiterate: prered = %g dirder = %g ratio = %g\n", prered, dirder,ratio);
#endif
/* update the step bound */
if (ratio > p25)
{
#ifdef DEBUG
printf("ratio > p25\n");
#endif
if (state->par == 0 || ratio >= p75)
{
state->delta = pnorm / p5;
state->par *= p5;
#ifdef DEBUG
printf("updated step bounds: delta = %g, par = %g\n", state->delta, state->par);
#endif
}
}
else
{
double temp = (actred >= 0) ? p5 : p5*dirder / (dirder + p5 * actred);
#ifdef DEBUG
printf("ratio < p25\n");
#endif
if (p1 * fnorm1 >= state->fnorm || temp < p1 )
{
temp = p1;
}
state->delta = temp * GSL_MIN_DBL (state->delta, pnorm/p1);
state->par /= temp;
#ifdef DEBUG
printf("updated step bounds: delta = %g, par = %g\n", state->delta, state->par);
#endif
}
/* test for successful iteration, termination and stringent tolerances */
if (ratio >= p0001)
{
gsl_vector_memcpy (x, x_trial);
gsl_vector_memcpy (f, f_trial);
/* return immediately if evaluation raised error */
{
int status;
if (fdf->df)
status = GSL_MULTIFIT_FN_EVAL_DF (fdf, x_trial, J);
else
status = gsl_multifit_fdfsolver_dif_df(x_trial, fdf, f_trial, J);
if (status)
return status;
}
/* wa2_j = diag_j * x_j */
state->xnorm = scaled_enorm(diag, x);
state->fnorm = fnorm1;
state->iter++;
/* Rescale if necessary */
if (scale)
{
update_diag (J, diag);
}
{
int signum;
gsl_matrix_memcpy (r, J);
gsl_linalg_QRPT_decomp (r, tau, perm, &signum, work1);
}
return GSL_SUCCESS;
}
else if (fabs(actred) <= GSL_DBL_EPSILON && prered <= GSL_DBL_EPSILON
&& p5 * ratio <= 1.0)
{
return GSL_ETOLF ;
}
else if (state->delta <= GSL_DBL_EPSILON * state->xnorm)
{
return GSL_ETOLX;
}
else if (gnorm <= GSL_DBL_EPSILON)
{
return GSL_ETOLG;
}
else if (iter < 10)
{
/* Repeat inner loop if unsuccessful */
goto lm_iteration;
}
return GSL_ENOPROG;
}
/**
* C++ version of gsl_linalg_QR_QTvec().
* @param QR A QR decomposition matrix
* @param tau A vector
* @param v A vector
* @return Error code on failure
*/
inline int QR_QTvec( matrix const& QR, vector const& tau, vector& v ){
return gsl_linalg_QR_QTvec( QR.get(), tau.get(), v.get() ); }
int lseShurComplement(gsl_matrix * A, gsl_matrix * C,
gsl_vector * b, gsl_vector * d,
gsl_vector * x, gsl_vector * lambda, double * sigma)
{
int i;
double xi;
gsl_vector *c0, *S, *tau;
gsl_matrix *CT, *U;
gsl_permutation *perm;
gsl_vector_view row, cp;
gsl_matrix_view R;
if (A->size2 != C->size2) return -1;
if (A->size2 != x->size) return -1;
if (A->size1 < A->size2) return -1;
if (b != NULL && A->size1 != b->size) return -1;
if (C->size1 != d->size) return -1;
if (C->size1 != lambda->size) return -1;
c0 = gsl_vector_alloc(x->size);
gsl_matrix_get_row(c0, C, 0);
/* Cholesky factorization of A^T A = R^T R via QRPT decomposition */
perm = gsl_permutation_alloc(x->size);
tau = gsl_vector_alloc(x->size);
gsl_linalg_QRPT_decomp(A, tau, perm, &i, x);
/* cp = R^{-T} P A^T b = Q^T b */
if (b != NULL) {
gsl_linalg_QR_QTvec(A, tau, b);
cp = gsl_vector_subvector(b, 0, x->size);
}
gsl_vector_free(tau);
/* C P -> C */
R = gsl_matrix_submatrix(A, 0, 0, A->size2, A->size2);
for (i = 0; i < C->size1; ++i) {
row = gsl_matrix_row(C, i);
gsl_permute_vector(perm, &row.vector);
}
/* Compute C inv(R) -> C */
gsl_blas_dtrsm(CblasRight, CblasUpper, CblasNoTrans, CblasNonUnit, 1.0,
&R.matrix, C);
/* The Schur complement D = C C^T,
Compute SVD of D = U S^2 U^T by SVD of C^T = V S U^T */
CT = gsl_matrix_alloc(C->size2, C->size1);
gsl_matrix_transpose_memcpy(CT, C);
U = gsl_matrix_alloc(CT->size2, CT->size2);
S = gsl_vector_alloc(CT->size2);
gsl_linalg_SV_decomp(CT, U, S, lambda);
/* Right hand side of the Shur complement system
d - C (A^T A)^-1 A^T b = d - C cp -> d
(with C P R^-1 -> C and R^-T P^T A^T b -> cp) */
if (b != NULL) {
gsl_blas_dgemv(CblasNoTrans, -1.0, C, &cp.vector, 1.0, d);
}
/* Calculate S U^T lambda, where -lambda is the Lagrange multiplier */
gsl_blas_dgemv(CblasTrans, 1.0, U, d, 0.0, lambda);
gsl_vector_div(lambda, S);
/* Calculate sigma = || A x ||_2 = || x ||_2 (before inv(R) x -> x) */
*sigma = gsl_blas_dnrm2(lambda);
/* Compute inv(R)^T C^T lambda = C^T lambda (with C inv(R) ->C) */
gsl_blas_dgemv(CblasNoTrans, 1.0, CT, lambda, 0.0, x);
/* x = inv(A^T A) C^T lambda = inv(R) [inv(R)^T C^T lambda] */
if (R.matrix.data[R.matrix.size1 * R.matrix.size2 - 1] != 0.0) {
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &R.matrix, x);
}
else { /* Special case when A is singular */
gsl_vector_set_basis(x, x->size - 1);
*sigma = 0.0;
}
/* Permute back, 1-step iterative refinement on first constraint */
gsl_permute_vector_inverse(perm, x);
gsl_blas_ddot(x, c0, &xi);
gsl_vector_scale(x, d->data[0] / xi);
/* get the real lambda from S U^T lambda previously stored in lambda */
gsl_vector_div(lambda, S);
gsl_vector_memcpy(S, lambda);
gsl_blas_dgemv(CblasNoTrans, 1.0, U, S, 0.0, lambda);
gsl_vector_free(c0);
gsl_vector_free(S);
gsl_matrix_free(U);
gsl_matrix_free(CT);
gsl_permutation_free(perm);
return 0;
}
int
gsl_multifit_linear_wgenform2 (const gsl_matrix * LQR,
const gsl_vector * Ltau,
const gsl_matrix * X,
const gsl_vector * w,
const gsl_vector * y,
const gsl_vector * cs,
const gsl_matrix * M,
gsl_vector * c,
gsl_multifit_linear_workspace * work)
{
const size_t m = LQR->size1;
const size_t n = X->size1;
const size_t p = X->size2;
if (n > work->nmax || p > work->pmax)
{
GSL_ERROR("X matrix does not match workspace", GSL_EBADLEN);
}
else if (p != LQR->size2)
{
GSL_ERROR("LQR matrix does not match X", GSL_EBADLEN);
}
else if (p != c->size)
{
GSL_ERROR("c vector does not match X", GSL_EBADLEN);
}
else if (w != NULL && n != w->size)
{
GSL_ERROR("w vector does not match X", GSL_EBADLEN);
}
else if (n != y->size)
{
GSL_ERROR("y vector does not match X", GSL_EBADLEN);
}
else if (m >= p) /* square or tall L matrix */
{
if (p != cs->size)
{
GSL_ERROR("cs vector must be length p", GSL_EBADLEN);
}
else
{
int s;
gsl_matrix_const_view R = gsl_matrix_const_submatrix(LQR, 0, 0, p, p); /* R factor of L */
/* solve R c = cs for true solution c, using QR decomposition of L */
gsl_vector_memcpy(c, cs);
s = gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &R.matrix, c);
return s;
}
}
else /* rectangular L matrix with m < p */
{
if (m != cs->size)
{
GSL_ERROR("cs vector must be length m", GSL_EBADLEN);
}
else if (n != M->size1 || p != M->size2)
{
GSL_ERROR("M matrix must be size n-by-p", GSL_EBADLEN);
}
else
{
int status;
const size_t pm = p - m;
gsl_matrix_view A = gsl_matrix_submatrix(work->A, 0, 0, n, p);
gsl_vector_view b = gsl_vector_subvector(work->t, 0, n);
gsl_matrix_view Rp = gsl_matrix_view_array(LQR->data, m, m); /* R_p */
gsl_matrix_view LTQR = gsl_matrix_view_array(LQR->data, p, m);
gsl_vector_const_view LTtau = gsl_vector_const_subvector(Ltau, 0, m);
gsl_matrix_const_view MQR = gsl_matrix_const_submatrix(M, 0, 0, n, pm);
gsl_vector_const_view Mtau = gsl_matrix_const_subcolumn(M, p - 1, 0, GSL_MIN(n, pm));
gsl_matrix_const_view To = gsl_matrix_const_submatrix(&MQR.matrix, 0, 0, pm, pm);
gsl_vector_view workp = gsl_vector_subvector(work->xt, 0, p);
gsl_vector_view v1, v2;
/* compute A = sqrt(W) X and b = sqrt(W) y */
status = gsl_multifit_linear_applyW(X, w, y, &A.matrix, &b.vector);
if (status)
return status;
/* initialize c to zero */
gsl_vector_set_zero(c);
/* compute c = L_inv cs = K_p R_p^{-T} cs */
/* set c(1:m) = R_p^{-T} cs */
v1 = gsl_vector_subvector(c, 0, m);
gsl_vector_memcpy(&v1.vector, cs);
gsl_blas_dtrsv(CblasUpper, CblasTrans, CblasNonUnit, &Rp.matrix, &v1.vector);
/* c <- K R_p^{-T} cs = [ K_p R_p^{_T} cs ; 0 ] */
gsl_linalg_QR_Qvec(<QR.matrix, <tau.vector, c);
/* compute: b1 = b - A L_inv cs */
gsl_blas_dgemv(CblasNoTrans, -1.0, &A.matrix, c, 1.0, &b.vector);
/* compute: b2 = H^T b1 */
gsl_linalg_QR_QTvec(&MQR.matrix, &Mtau.vector, &b.vector);
/* compute: b3 = T_o^{-1} b2 */
v1 = gsl_vector_subvector(&b.vector, 0, pm);
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &To.matrix, &v1.vector);
/* compute: b4 = K_o b3 */
gsl_vector_set_zero(&workp.vector);
v2 = gsl_vector_subvector(&workp.vector, m, pm);
gsl_vector_memcpy(&v2.vector, &v1.vector);
gsl_linalg_QR_Qvec(<QR.matrix, <tau.vector, &workp.vector);
/* final solution vector */
gsl_vector_add(c, &workp.vector);
return GSL_SUCCESS;
}
}
}
int
gsl_multifit_linear_wstdform2 (const gsl_matrix * LQR,
const gsl_vector * Ltau,
const gsl_matrix * X,
const gsl_vector * w,
const gsl_vector * y,
gsl_matrix * Xs,
gsl_vector * ys,
gsl_matrix * M,
gsl_multifit_linear_workspace * work)
{
const size_t m = LQR->size1;
const size_t n = X->size1;
const size_t p = X->size2;
if (n > work->nmax || p > work->pmax)
{
GSL_ERROR("observation matrix larger than workspace", GSL_EBADLEN);
}
else if (p != LQR->size2)
{
GSL_ERROR("LQR and X matrices have different numbers of columns", GSL_EBADLEN);
}
else if (n != y->size)
{
GSL_ERROR("y vector does not match X", GSL_EBADLEN);
}
else if (w != NULL && n != w->size)
{
GSL_ERROR("weights vector must be length n", GSL_EBADLEN);
}
else if (m >= p) /* square or tall L matrix */
{
/* the sizes of Xs and ys depend on whether m >= p or m < p */
if (n != Xs->size1 || p != Xs->size2)
{
GSL_ERROR("Xs matrix must be n-by-p", GSL_EBADLEN);
}
else if (n != ys->size)
{
GSL_ERROR("ys vector must have length n", GSL_EBADLEN);
}
else
{
int status;
size_t i;
gsl_matrix_const_view R = gsl_matrix_const_submatrix(LQR, 0, 0, p, p);
/* compute Xs = sqrt(W) X and ys = sqrt(W) y */
status = gsl_multifit_linear_applyW(X, w, y, Xs, ys);
if (status)
return status;
/* compute X~ = X R^{-1} using QR decomposition of L */
for (i = 0; i < n; ++i)
{
gsl_vector_view v = gsl_matrix_row(Xs, i);
/* solve: R^T y = X_i */
gsl_blas_dtrsv(CblasUpper, CblasTrans, CblasNonUnit, &R.matrix, &v.vector);
}
return GSL_SUCCESS;
}
}
else /* L matrix with m < p */
{
const size_t pm = p - m;
const size_t npm = n - pm;
/*
* This code closely follows section 2.6.1 of Hansen's
* "Regularization Tools" manual
*/
if (npm != Xs->size1 || m != Xs->size2)
{
GSL_ERROR("Xs matrix must be (n-p+m)-by-m", GSL_EBADLEN);
}
else if (npm != ys->size)
{
GSL_ERROR("ys vector must be of length (n-p+m)", GSL_EBADLEN);
}
else if (n != M->size1 || p != M->size2)
{
GSL_ERROR("M matrix must be n-by-p", GSL_EBADLEN);
}
else
{
int status;
gsl_matrix_view A = gsl_matrix_submatrix(work->A, 0, 0, n, p);
gsl_vector_view b = gsl_vector_subvector(work->t, 0, n);
gsl_matrix_view LTQR = gsl_matrix_view_array(LQR->data, p, m); /* qr(L^T) */
gsl_matrix_view Rp = gsl_matrix_view_array(LQR->data, m, m); /* R factor of L^T */
gsl_vector_const_view LTtau = gsl_vector_const_subvector(Ltau, 0, m);
/*
* M(:,1:p-m) will hold QR decomposition of A K_o; M(:,p) will hold
* Householder scalars
*/
gsl_matrix_view MQR = gsl_matrix_submatrix(M, 0, 0, n, pm);
gsl_vector_view Mtau = gsl_matrix_subcolumn(M, p - 1, 0, GSL_MIN(n, pm));
gsl_matrix_view AKo, AKp, HqTAKp;
gsl_vector_view v;
size_t i;
/* compute A = sqrt(W) X and b = sqrt(W) y */
status = gsl_multifit_linear_applyW(X, w, y, &A.matrix, &b.vector);
if (status)
return status;
/* compute: A <- A K = [ A K_p ; A K_o ] */
gsl_linalg_QR_matQ(<QR.matrix, <tau.vector, &A.matrix);
AKp = gsl_matrix_submatrix(&A.matrix, 0, 0, n, m);
AKo = gsl_matrix_submatrix(&A.matrix, 0, m, n, pm);
/* compute QR decomposition [H,T] = qr(A * K_o) and store in M */
gsl_matrix_memcpy(&MQR.matrix, &AKo.matrix);
gsl_linalg_QR_decomp(&MQR.matrix, &Mtau.vector);
/* AKp currently contains A K_p; apply H^T from the left to get H^T A K_p */
gsl_linalg_QR_QTmat(&MQR.matrix, &Mtau.vector, &AKp.matrix);
/* the last npm rows correspond to H_q^T A K_p */
HqTAKp = gsl_matrix_submatrix(&AKp.matrix, pm, 0, npm, m);
/* solve: Xs R_p^T = H_q^T A K_p for Xs */
gsl_matrix_memcpy(Xs, &HqTAKp.matrix);
for (i = 0; i < npm; ++i)
{
gsl_vector_view x = gsl_matrix_row(Xs, i);
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &Rp.matrix, &x.vector);
}
/*
* compute: ys = H_q^T b; this is equivalent to computing
* the last q elements of H^T b (q = npm)
*/
v = gsl_vector_subvector(&b.vector, pm, npm);
gsl_linalg_QR_QTvec(&MQR.matrix, &Mtau.vector, &b.vector);
gsl_vector_memcpy(ys, &v.vector);
return GSL_SUCCESS;
}
}
}
