/*assumes we have a "coded" QR decomposition (a,tau) of the original matrix*/
inline void qr_decomp(double* a, double* tau, double* q, double* r,int m,int n){
gsl_matrix_view qv=gsl_matrix_view_array(q,m,m);
gsl_matrix_view rv=gsl_matrix_view_array(r,m,n);
gsl_matrix_view av=gsl_matrix_view_array(a,m,n);
int d;
if (m<n) d=m; else d=n;
gsl_vector_view tv=gsl_vector_view_array(tau,d);
gsl_linalg_QR_unpack(&av.matrix,&tv.vector,&qv.matrix,&rv.matrix);
}
CAMLprim value ml_gsl_linalg_QR_unpack(value QR, value TAU, value Q, value R)
{
_DECLARE_MATRIX3(QR, Q, R);
_DECLARE_VECTOR(TAU);
_CONVERT_MATRIX3(QR, Q, R);
_CONVERT_VECTOR(TAU);
gsl_linalg_QR_unpack(&m_QR, &v_TAU, &m_Q, &m_R);
return Val_unit;
}
/* compute QR factorization
M is mxn; Q is mxm and R is mxn
this is slow
*/
void compute_QR_factorization(gsl_matrix *M, gsl_matrix *Q, gsl_matrix *R){
//printf("QR setup..\n");
gsl_matrix *QR = gsl_matrix_calloc(M->size1, M->size2);
gsl_vector *tau = gsl_vector_alloc(min(M->size1,M->size2));
gsl_matrix_memcpy (QR, M);
//printf("QR decomp..\n");
gsl_linalg_QR_decomp (QR, tau);
//printf("QR unpack..\n");
gsl_linalg_QR_unpack (QR, tau, Q, R);
//printf("done QR..\n");
}
/* generate random square orthogonal matrix via QR decomposition */
static void
test_random_matrix_orth(gsl_matrix *m, const gsl_rng *r)
{
const size_t M = m->size1;
gsl_matrix *A = gsl_matrix_alloc(M, M);
gsl_vector *tau = gsl_vector_alloc(M);
gsl_matrix *R = gsl_matrix_alloc(M, M);
test_random_matrix(A, r, -1.0, 1.0);
gsl_linalg_QR_decomp(A, tau);
gsl_linalg_QR_unpack(A, tau, m, R);
gsl_matrix_free(A);
gsl_matrix_free(R);
gsl_vector_free(tau);
}
static int
set (void *vstate, gsl_multiroot_function * func, gsl_vector * x, gsl_vector * f, gsl_vector * dx, int scale)
{
hybrid_state_t *state = (hybrid_state_t *) vstate;
gsl_matrix *J = state->J;
gsl_matrix *q = state->q;
gsl_matrix *r = state->r;
gsl_vector *tau = state->tau;
gsl_vector *diag = state->diag;
GSL_MULTIROOT_FN_EVAL (func, x, f);
gsl_multiroot_fdjacobian (func, x, f, GSL_SQRT_DBL_EPSILON, J) ;
state->iter = 1;
state->fnorm = enorm (f);
state->ncfail = 0;
state->ncsuc = 0;
state->nslow1 = 0;
state->nslow2 = 0;
gsl_vector_set_all (dx, 0.0);
/* Store column norms in diag */
if (scale)
compute_diag (J, diag);
else
gsl_vector_set_all (diag, 1.0);
/* Set delta to factor |D x| or to factor if |D x| is zero */
state->delta = compute_delta (diag, x);
/* Factorize J into QR decomposition */
gsl_linalg_QR_decomp (J, tau);
gsl_linalg_QR_unpack (J, tau, q, r);
return GSL_SUCCESS;
}
static int
md_qr(lua_State *L) /* (-1,+2,e) */
{
mMatReal *m = qlua_checkMatReal(L, 1);
mMatReal *qr = qlua_newMatReal(L, m->l_size, m->r_size);
mMatReal *q = qlua_newMatReal(L, m->l_size, m->l_size);
mMatReal *r = qlua_newMatReal(L, m->l_size, m->r_size);
int nm = m->l_size < m->r_size? m->l_size: m->r_size;
gsl_vector *tau;
gsl_matrix_memcpy(qr->m, m->m);
tau = new_gsl_vector(L, nm);
if (gsl_linalg_QR_decomp(qr->m, tau))
luaL_error(L, "matrix:qr() failed");
if (gsl_linalg_QR_unpack(qr->m, tau, q->m, r->m))
luaL_error(L, "matrix:qr() failed");
gsl_vector_free(tau);
return 2;
}
int
gsl_linalg_QRPT_decomp2 (const gsl_matrix * A, gsl_matrix * q, gsl_matrix * r, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm)
{
const size_t M = A->size1;
const size_t N = A->size2;
if (q->size1 != M || q->size2 !=M)
{
GSL_ERROR ("q must be M x M", GSL_EBADLEN);
}
else if (r->size1 != M || r->size2 !=N)
{
GSL_ERROR ("r must be M x N", GSL_EBADLEN);
}
else if (tau->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
}
else if (p->size != N)
{
GSL_ERROR ("permutation size must be N", GSL_EBADLEN);
}
else if (norm->size != N)
{
GSL_ERROR ("norm size must be N", GSL_EBADLEN);
}
gsl_matrix_memcpy (r, A);
gsl_linalg_QRPT_decomp (r, tau, p, signum, norm);
/* FIXME: aliased arguments depends on behavior of unpack routine! */
gsl_linalg_QR_unpack (r, tau, q, r);
return GSL_SUCCESS;
}
/**
* C++ version of gsl_linalg_QR_unpack().
* @param QR A QR decomposition matrix
* @param tau A vector
* @param Q A matrix
* @param R A matrix
* @return Error code on failure
*/
inline int QR_unpack( matrix const& QR, vector const& tau, matrix& Q, matrix& R ){
return gsl_linalg_QR_unpack( QR.get(), tau.get(), Q.get(), R.get() ); }
static int
iterate (void *vstate, gsl_multiroot_function * func, gsl_vector * x, gsl_vector * f, gsl_vector * dx, int scale)
{
hybrid_state_t *state = (hybrid_state_t *) vstate;
const double fnorm = state->fnorm;
gsl_matrix *J = state->J;
gsl_matrix *q = state->q;
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 *df = state->df;
gsl_vector *qtdf = state->qtdf;
gsl_vector *rdx = state->rdx;
gsl_vector *w = state->w;
gsl_vector *v = state->v;
double prered, actred;
double pnorm, fnorm1, fnorm1p;
double ratio;
double p1 = 0.1, p5 = 0.5, p001 = 0.001, p0001 = 0.0001;
/* Compute qtf = Q^T f */
compute_qtf (q, f, qtf);
/* Compute dogleg step */
dogleg (r, qtf, diag, state->delta, state->newton, state->gradient, dx);
/* Take a trial step */
compute_trial_step (x, dx, state->x_trial);
pnorm = scaled_enorm (diag, dx);
if (state->iter == 1)
{
if (pnorm < state->delta)
{
state->delta = pnorm;
}
}
/* Evaluate function at x + p */
{
int status = GSL_MULTIROOT_FN_EVAL (func, x_trial, f_trial);
if (status != GSL_SUCCESS)
{
return GSL_EBADFUNC;
}
}
/* Set df = f_trial - f */
compute_df (f_trial, f, df);
/* Compute the scaled actual reduction */
fnorm1 = enorm (f_trial);
actred = compute_actual_reduction (fnorm, fnorm1);
/* Compute rdx = R dx */
compute_rdx (r, dx, rdx);
/* Compute the scaled predicted reduction phi1p = |Q^T f + R dx| */
fnorm1p = enorm_sum (qtf, rdx);
prered = compute_predicted_reduction (fnorm, fnorm1p);
/* Compute the ratio of the actual to predicted reduction */
if (prered > 0)
{
ratio = actred / prered;
}
else
{
ratio = 0;
}
/* Update the step bound */
if (ratio < p1)
{
state->ncsuc = 0;
state->ncfail++;
state->delta *= p5;
}
else
{
state->ncfail = 0;
state->ncsuc++;
if (ratio >= p5 || state->ncsuc > 1)
state->delta = GSL_MAX (state->delta, pnorm / p5);
if (fabs (ratio - 1) <= p1)
state->delta = pnorm / p5;
}
/* Test for successful iteration */
if (ratio >= p0001)
{
gsl_vector_memcpy (x, x_trial);
gsl_vector_memcpy (f, f_trial);
state->fnorm = fnorm1;
state->iter++;
}
/* Determine the progress of the iteration */
state->nslow1++;
if (actred >= p001)
state->nslow1 = 0;
if (actred >= p1)
state->nslow2 = 0;
if (state->ncfail == 2)
{
gsl_multiroot_fdjacobian (func, x, f, GSL_SQRT_DBL_EPSILON, J) ;
state->nslow2++;
if (state->iter == 1)
{
if (scale)
compute_diag (J, diag);
state->delta = compute_delta (diag, x);
}
else
{
if (scale)
update_diag (J, diag);
}
/* Factorize J into QR decomposition */
gsl_linalg_QR_decomp (J, tau);
gsl_linalg_QR_unpack (J, tau, q, r);
return GSL_SUCCESS;
}
/* Compute qtdf = Q^T df, w = (Q^T df - R dx)/|dx|, v = D^2 dx/|dx| */
compute_qtf (q, df, qtdf);
compute_wv (qtdf, rdx, dx, diag, pnorm, w, v);
/* Rank-1 update of the jacobian Q'R' = Q(R + w v^T) */
gsl_linalg_QR_update (q, r, w, v);
/* No progress as measured by jacobian evaluations */
if (state->nslow2 == 5)
{
return GSL_ENOPROGJ;
}
/* No progress as measured by function evaluations */
if (state->nslow1 == 10)
{
return GSL_ENOPROG;
}
return GSL_SUCCESS;
}
void Module_DLT::rq_decomp(double* solucion,
gsl_matrix* R_prima,
gsl_matrix* Q_prima,
gsl_vector* x
){
/*
int i, j, lotkin_signum, frank_signum;
int DIM = 3;
gsl_matrix *lotkin_a, *frank_a;
gsl_vector *x, *lotkin_b, *frank_b, *lotkin_x, *frank_x;
gsl_vector *lotkin_tau, *frank_tau;
/* allocate a, x, b
lotkin_a = gsl_matrix_alloc(DIM, DIM);
frank_a = gsl_matrix_alloc(DIM, DIM);
x = gsl_vector_alloc(DIM);
lotkin_b = gsl_vector_alloc(DIM);
frank_b = gsl_vector_alloc(DIM);
lotkin_x = gsl_vector_alloc(DIM);
frank_x = gsl_vector_alloc(DIM);
/* set x = [1 2 ... DIM]
for(i = 0; i < DIM; i++)
gsl_vector_set(x, i, (double)i);
/* set Lotkin matrix */
/* a_ij = 1 (i = 1) or 1/(i+j-1) (i != 1)
for(i = 0; i < DIM; i++)
gsl_matrix_set(lotkin_a, 0, i, 1.0);
for(i = 1; i < DIM; i++)
for(j = 0; j < DIM; j++)
gsl_matrix_set(lotkin_a, i, j, 1.0 / (double)(i + j + 1));
/* set Frank matrix
/* a_ij = DIM - min(i,j) + 1
for(i = 0; i < DIM; i++)
for(j = 0; j < DIM; j++)
gsl_matrix_set(frank_a, i, j, (double)DIM - (double)GSL_MAX(i, j) );
*/
/* set A matrix
gsl_matrix_set(lotkin_a, 0, 0, 12);
gsl_matrix_set(lotkin_a, 0, 1, 6);
gsl_matrix_set(lotkin_a, 0, 2, -4);
gsl_matrix_set(lotkin_a, 1, 0, -51);
gsl_matrix_set(lotkin_a, 1, 1, 167);
gsl_matrix_set(lotkin_a, 1, 2, 24);
gsl_matrix_set(lotkin_a, 2, 0, 4);
gsl_matrix_set(lotkin_a, 2, 1, -68);
gsl_matrix_set(lotkin_a, 2, 2, -41);
/* Print matrix
for(i = 0; i < DIM; i++)
{
printf("%3d: ", i);
for(j = 0; j < DIM; j++)
printf("%g ", gsl_matrix_get(lotkin_a, i, j));
printf("\n");
}
printf("\n");
/* b = A * x
gsl_blas_dgemv(CblasNoTrans, 1.0, lotkin_a, x, 0.0, lotkin_b);
/* QR decomposition and solve
lotkin_tau = gsl_vector_alloc(DIM);
gsl_linalg_QR_decomp(lotkin_a, lotkin_tau);
gsl_linalg_QR_solve(lotkin_a, lotkin_tau, lotkin_b, lotkin_x);
gsl_vector_free(lotkin_tau);
/* Print solution matrix
for(i = 0; i < DIM; i++)
{
printf("%3d: ", i);
for(j = 0; j < DIM; j++)
printf("%g ", gsl_matrix_get(lotkin_a, i, j));
printf("\n");
}
printf("\n");
for(i = 0; i < DIM; i++)
{
printf("%3d: ", i);
for(j = 0; j < DIM; j++)
//printf("%g ", gsl_vector_get(lotkin_x, i, j));
printf("\n");
}
/* free a, x, b
gsl_matrix_free(lotkin_a);
gsl_vector_free(x);
gsl_vector_free(lotkin_b);
gsl_vector_free(lotkin_x);
*/
/*
gsl_matrix* C = gsl_matrix_alloc(3,3);
/* Compute C = A B
gsl_blas_dgemm (CblasNoTrans, CblasNoTrans,
1.0, R_prima, Q_prima,
0.0, C);
camera->rt11 = gsl_matrix_get(C, 0, 0);
camera->rt12 = gsl_matrix_get(C, 0, 1);
camera->rt13 = gsl_matrix_get(C, 0, 2);
camera->rt21 = gsl_matrix_get(C, 1, 0);
camera->rt22 = gsl_matrix_get(C, 1, 1);
camera->rt23 = gsl_matrix_get(C, 1, 2);
camera->rt31 = gsl_matrix_get(C, 2, 0);
camera->rt32 = gsl_matrix_get(C, 2, 1);
camera->rt33 = gsl_matrix_get(C, 2, 2);
camera->rt41 = 0;
camera->rt42 = 0;
camera->rt43 = 0;
camera->rt44 = 1;
**/
std::cout << "RQ_Decomp" << std::endl;
int n,mm,s,signum ;
gsl_matrix *M,*Q,*R;
gsl_vector* tau;
double tmp,det;
/* para invertir las matriz M,Q,R */
gsl_permutation* p = gsl_permutation_alloc (3);
gsl_permutation* p2 = gsl_permutation_alloc (3);
gsl_permutation* p3 = gsl_permutation_alloc (3);
gsl_matrix* M_prima = gsl_matrix_alloc(3,3);
gsl_matrix* Q_prima_tmp = gsl_matrix_alloc(3,3);
/* para resolver el centro de la camara usando Mx=C
donde C es el verctor p4 de la matriz P */
gsl_vector* p4 = gsl_vector_alloc(3);
gsl_matrix* temp = gsl_matrix_alloc(3,3);
gsl_matrix* I_C = gsl_matrix_alloc(3,4);
gsl_matrix* test = gsl_matrix_alloc(3,4);
M = gsl_matrix_alloc(3,3);
Q = gsl_matrix_alloc(3,3);
R = gsl_matrix_alloc(3,3);
tau = gsl_vector_alloc(3);
/* Copiamos la submatriz 3x3 Izq de la solucion P a la matriz M */
gsl_matrix_set(M,0,0,solucion[0]);
gsl_matrix_set(M,0,1,solucion[1]);
gsl_matrix_set(M,0,2,solucion[2]);
gsl_matrix_set(M,1,0,solucion[4]);
gsl_matrix_set(M,1,1,solucion[5]);
gsl_matrix_set(M,1,2,solucion[6]);
gsl_matrix_set(M,2,0,solucion[8]);
gsl_matrix_set(M,2,1,solucion[9]);
gsl_matrix_set(M,2,2,solucion[10]);
/* Copiamos el vector p4 */
gsl_vector_set(p4,0,solucion[3]);
gsl_vector_set(p4,1,solucion[7]);
gsl_vector_set(p4,2,solucion[11]);
/* invertimos la matriz M */
gsl_linalg_LU_decomp (M, p, &s);
gsl_linalg_LU_solve(M,p,p4,x);
gsl_linalg_LU_invert (M, p, M_prima);
/* Hacemos una descomposicion a la matriz M invertida */
gsl_linalg_QR_decomp (M_prima,tau);
gsl_linalg_QR_unpack (M_prima,tau,Q,R);
/* Invertimos R */
gsl_linalg_LU_decomp (R, p2, &s);
gsl_linalg_LU_invert (R, p2, R_prima);
/* Invertimos Q */
gsl_linalg_LU_decomp (Q, p3, &s);
gsl_linalg_LU_invert (Q, p3, Q_prima);
gsl_matrix_memcpy(Q_prima_tmp, Q_prima);
std::cout << "Calculamos" << std::endl;
if (DEBUG) {
/** checking results:
If the rq decompsition is correct we should obtain
the decomposed matrix:
orig_matrix = K*R*T
where T = (I|C)
*/
gsl_matrix_set(I_C,0,3,gsl_vector_get(x,0));
gsl_matrix_set(I_C,1,3,gsl_vector_get(x,1));
gsl_matrix_set(I_C,2,3,gsl_vector_get(x,2));
gsl_matrix_set(I_C,0,0,1);
gsl_matrix_set(I_C,0,1,0);
gsl_matrix_set(I_C,0,2,0);
gsl_matrix_set(I_C,1,0,0);
gsl_matrix_set(I_C,1,1,1);
gsl_matrix_set(I_C,1,2,0);
gsl_matrix_set(I_C,2,0,0);
gsl_matrix_set(I_C,2,1,0);
gsl_matrix_set(I_C,2,2,1);
gsl_linalg_matmult(R_prima,Q_prima,temp);
gsl_linalg_matmult(temp,I_C,test);
printf(" Result -> \n");
for (n=0; n<3; n++){
// for (mm=0; mm<4; mm++){
for (mm=0; mm<3; mm++){
printf(" %g \t",gsl_matrix_get(temp,n,mm));
// se debe sacar test
}
printf("\n");
}
}
/* El elemento (3,3) de la matriz R tiene que ser 1
para ello tenemos que normalizar la matriz dividiendo
entre este elemento
*/
tmp = gsl_matrix_get(R_prima,2,2);
for (n=0; n<3; n++)
for (mm=0; mm<3; mm++){
gsl_matrix_set(R_prima,n,mm, gsl_matrix_get(R_prima,n,mm)/tmp);
}
/* Si obtenemos valores negativos en la
diagonal de K tenemos que cambiar de signo la columna de K y la fila de Q
correspondiente
*/
if (DEBUG)
print_matrix(R_prima);
if (DEBUG)
print_matrix(Q_prima);
if (gsl_matrix_get(R_prima,0,0)<0){
if (DEBUG) printf(" distancia focat 0,0 negativa\n");
gsl_matrix_set(R_prima,0,0,
abs(gsl_matrix_get(R_prima,0,0))
);
for (n=0;n<3;n++)
gsl_matrix_set(Q_prima,0,n,
gsl_matrix_get(Q_prima,0,n)*-1
);
}
if (DEBUG) printf("R_prima\n");
print_matrix(R_prima);
if (DEBUG) printf("Q_prima\n");
print_matrix(Q_prima);
if (gsl_matrix_get(R_prima,1,1)<0){
if (DEBUG) printf(" distancia focal 1,1 negativa\n");
for (n=0;n<3;n++){
gsl_matrix_set(Q_prima,1,n,
gsl_matrix_get(Q_prima,1,n)*-1
);
gsl_matrix_set(R_prima,n,1,
gsl_matrix_get(R_prima,n,1)*-1
);
}
}
if (DEBUG) printf("R_prima\n");
print_matrix(R_prima);
if (DEBUG) printf("Q_prima\n");
print_matrix(Q_prima);
/*Finalmente, si Q queda con determinante -1 cambiamos de signo
todos sus elementos para obtener una rotación sin "reflexion".
NOTA: Este trozo de codigo lo he desactivado debido a que si lo
hacemos obtenemos una orientacion equivocada a la hora de dibujarla
con OGL
*/
gsl_linalg_LU_decomp (Q_prima_tmp, p3, &s);
signum=1;
det = gsl_linalg_LU_det(Q_prima_tmp,signum);
if (-1 == det && 0){
if (DEBUG) printf("Q has a negatif det");
for (n=0;n<3;n++)
for (mm=0;mm<3;mm++)
gsl_matrix_set(Q_prima,n,mm,gsl_matrix_get(Q_prima,n,mm)*-1);
}
}
int main() {
int ret;
int i, j;
gsl_vector* tau;
gsl_matrix *A;
gsl_matrix *Q, *R, *RTR;
gsl_matrix_view Rtop;
int M = 4;
int N = 3;
/*
gsl_matrix A;
double data[9];
memset(&A, 0, sizeof(gsl_matrix));
A.size1 = 3;
A.size2 = 3;
A.tda = 3;
A.data = data;
gsl_matrix_set(&A, 0, 0, 34.0);
gsl_matrix_set(&A, 0, 1, 4.0);
gsl_matrix_set(&A, 0, 2, 14.0);
gsl_matrix_set(&A, 1, 0, 1.0);
gsl_matrix_set(&A, 1, 1, 8.0);
gsl_matrix_set(&A, 1, 2, 3.0);
gsl_matrix_set(&A, 2, 0, 7.0);
gsl_matrix_set(&A, 2, 1, 1.0);
gsl_matrix_set(&A, 2, 2, 8.0);
*/
A = gsl_matrix_alloc(M, N);
for (i=0; i<M; i++)
for (j=0; j<N; j++)
gsl_matrix_set(A, i, j, (double)rand()/(double)RAND_MAX);
for (i=0; i<A->size1; i++) {
printf((i==0) ? "A = (" : " (");
for (j=0; j<A->size2; j++) {
printf(" %12.5g ", gsl_matrix_get(A, i, j));
}
printf(")\n");
}
printf("\n");
tau = gsl_vector_alloc(N);
ret = gsl_linalg_QR_decomp(A, tau);
Q = gsl_matrix_alloc(M, M);
R = gsl_matrix_alloc(M, N);
ret = gsl_linalg_QR_unpack(A, tau, Q, R);
for (i=0; i<Q->size1; i++) {
printf((i==0) ? "Q = (" : " (");
for (j=0; j<Q->size2; j++) {
printf(" %12.5g ", gsl_matrix_get(Q, i, j));
}
printf(")\n");
}
printf("\n");
for (i=0; i<R->size1; i++) {
printf((i==0) ? "R = (" : " (");
for (j=0; j<R->size2; j++) {
printf(" %12.5g ", gsl_matrix_get(R, i, j));
}
printf(")\n");
}
printf("\n");
Rtop = gsl_matrix_submatrix(R, 0, 0, N, N);
RTR = gsl_matrix_alloc(N, N);
gsl_matrix_memcpy(RTR, &(Rtop.matrix));
ret = gsl_blas_dtrmm(CblasLeft, CblasUpper, CblasTrans, CblasNonUnit,
1.0, RTR, RTR);
//(Rtop.matrix), &(Rtop.matrix));
for (i=0; i<RTR->size1; i++) {
printf((i==0) ? "RTR = (" : " (");
for (j=0; j<RTR->size2; j++) {
printf(" %12.5g ", gsl_matrix_get(RTR, i, j));
}
printf(")\n");
}
printf("\n");
gsl_matrix_free(RTR);
gsl_matrix_free(Q);
gsl_matrix_free(R);
gsl_vector_free(tau);
gsl_matrix_free(A);
return 0;
}
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() */
static void
linreg_fit_qr (const gsl_matrix *cov, linreg *l)
{
double intcpt_coef = 0.0;
double intercept_variance = 0.0;
gsl_matrix *xtx;
gsl_matrix *q;
gsl_matrix *r;
gsl_vector *xty;
gsl_vector *tau;
gsl_vector *params;
double tmp = 0.0;
size_t i;
size_t j;
xtx = gsl_matrix_alloc (cov->size1 - 1, cov->size2 - 1);
xty = gsl_vector_alloc (cov->size1 - 1);
tau = gsl_vector_alloc (cov->size1 - 1);
params = gsl_vector_alloc (cov->size1 - 1);
for (i = 0; i < xtx->size1; i++)
{
gsl_vector_set (xty, i, gsl_matrix_get (cov, cov->size2 - 1, i));
for (j = 0; j < xtx->size2; j++)
{
gsl_matrix_set (xtx, i, j, gsl_matrix_get (cov, i, j));
}
}
gsl_linalg_QR_decomp (xtx, tau);
q = gsl_matrix_alloc (xtx->size1, xtx->size2);
r = gsl_matrix_alloc (xtx->size1, xtx->size2);
gsl_linalg_QR_unpack (xtx, tau, q, r);
gsl_linalg_QR_solve (xtx, tau, xty, params);
for (i = 0; i < params->size; i++)
{
l->coeff[i] = gsl_vector_get (params, i);
}
l->sst = gsl_matrix_get (cov, cov->size1 - 1, cov->size2 - 1);
l->ssm = 0.0;
for (i = 0; i < l->n_indeps; i++)
{
l->ssm += gsl_vector_get (xty, i) * l->coeff[i];
}
l->sse = l->sst - l->ssm;
gsl_blas_dtrsm (CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, linreg_mse (l),
r, q);
/* Copy the lower triangle into the upper triangle. */
for (i = 0; i < q->size1; i++)
{
gsl_matrix_set (l->cov, i + 1, i + 1, gsl_matrix_get (q, i, i));
for (j = i + 1; j < q->size2; j++)
{
intercept_variance -= 2.0 * gsl_matrix_get (q, i, j) *
linreg_get_indep_variable_mean (l, i) *
linreg_get_indep_variable_mean (l, j);
gsl_matrix_set (q, i, j, gsl_matrix_get (q, j, i));
}
}
l->intercept = linreg_get_depvar_mean (l);
tmp = 0.0;
for (i = 0; i < l->n_indeps; i++)
{
tmp = linreg_get_indep_variable_mean (l, i);
l->intercept -= l->coeff[i] * tmp;
intercept_variance += tmp * tmp * gsl_matrix_get (q, i, i);
}
/* Covariances related to the intercept. */
intercept_variance += linreg_mse (l) / linreg_n_obs (l);
gsl_matrix_set (l->cov, 0, 0, intercept_variance);
for (i = 0; i < q->size1; i++)
{
for (j = 0; j < q->size2; j++)
{
intcpt_coef -= gsl_matrix_get (q, i, j)
* linreg_get_indep_variable_mean (l, j);
}
gsl_matrix_set (l->cov, 0, i + 1, intcpt_coef);
gsl_matrix_set (l->cov, i + 1, 0, intcpt_coef);
intcpt_coef = 0.0;
}
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (xty);
gsl_vector_free (tau);
gsl_matrix_free (xtx);
gsl_vector_free (params);
}
