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;
}
}
}
/**
* C++ version of gsl_linalg_QR_QTmat().
* @param QR A QR decomposition matrix
* @param tau A vector
* @param A A matrix
* @return Error code on failure
*/
inline int QR_QTmat( matrix const& QR, vector const& tau, matrix& A ){
return gsl_linalg_QR_QTmat( QR.get(), tau.get(), A.get() ); }
int
gsl_linalg_hesstri_decomp(gsl_matrix * A, gsl_matrix * B, gsl_matrix * U,
gsl_matrix * V, gsl_vector * work)
{
const size_t N = A->size1;
if ((N != A->size2) || (N != B->size1) || (N != B->size2))
{
GSL_ERROR ("Hessenberg-triangular reduction requires square matrices",
GSL_ENOTSQR);
}
else if (N != work->size)
{
GSL_ERROR ("length of workspace must match matrix dimension",
GSL_EBADLEN);
}
else
{
double cs, sn; /* rotation parameters */
size_t i, j; /* looping */
gsl_vector_view xv, yv; /* temporary views */
/* B -> Q^T B = R (upper triangular) */
gsl_linalg_QR_decomp(B, work);
/* A -> Q^T A */
gsl_linalg_QR_QTmat(B, work, A);
/* initialize U and V if desired */
if (U)
{
gsl_linalg_QR_unpack(B, work, U, B);
}
else
{
/* zero out lower triangle of B */
for (j = 0; j < N - 1; ++j)
{
for (i = j + 1; i < N; ++i)
gsl_matrix_set(B, i, j, 0.0);
}
}
if (V)
gsl_matrix_set_identity(V);
if (N < 3)
return GSL_SUCCESS; /* nothing more to do */
/* reduce A and B */
for (j = 0; j < N - 2; ++j)
{
for (i = N - 1; i >= (j + 2); --i)
{
/* step 1: rotate rows i - 1, i to kill A(i,j) */
/*
* compute G = [ CS SN ] so that G^t [ A(i-1,j) ] = [ * ]
* [-SN CS ] [ A(i, j) ] [ 0 ]
*/
gsl_linalg_givens(gsl_matrix_get(A, i - 1, j),
gsl_matrix_get(A, i, j),
&cs,
&sn);
/* invert so drot() works correctly (G -> G^t) */
sn = -sn;
/* compute G^t A(i-1:i, j:n) */
xv = gsl_matrix_subrow(A, i - 1, j, N - j);
yv = gsl_matrix_subrow(A, i, j, N - j);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
/* compute G^t B(i-1:i, i-1:n) */
xv = gsl_matrix_subrow(B, i - 1, i - 1, N - i + 1);
yv = gsl_matrix_subrow(B, i, i - 1, N - i + 1);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
if (U)
{
/* accumulate U: U -> U G */
xv = gsl_matrix_column(U, i - 1);
yv = gsl_matrix_column(U, i);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
}
/* step 2: rotate columns i, i - 1 to kill B(i, i - 1) */
gsl_linalg_givens(-gsl_matrix_get(B, i, i),
gsl_matrix_get(B, i, i - 1),
&cs,
&sn);
/* invert so drot() works correctly (G -> G^t) */
sn = -sn;
/* compute B(1:i, i-1:i) G */
xv = gsl_matrix_subcolumn(B, i - 1, 0, i + 1);
yv = gsl_matrix_subcolumn(B, i, 0, i + 1);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
/* apply to A(1:n, i-1:i) */
xv = gsl_matrix_column(A, i - 1);
yv = gsl_matrix_column(A, i);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
if (V)
{
/* accumulate V: V -> V G */
xv = gsl_matrix_column(V, i - 1);
yv = gsl_matrix_column(V, i);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
}
}
}
return GSL_SUCCESS;
}
} /* gsl_linalg_hesstri_decomp() */