int
gsl_multifit_linear_L_decomp (gsl_matrix * L, gsl_vector * tau)
{
const size_t m = L->size1;
const size_t p = L->size2;
int status;
if (tau->size != GSL_MIN(m, p))
{
GSL_ERROR("tau vector must be min(m,p)", GSL_EBADLEN);
}
else if (m >= p)
{
/* square or tall L matrix */
status = gsl_linalg_QR_decomp(L, tau);
return status;
}
else
{
/* more columns than rows, compute qr(L^T) */
gsl_matrix_view LTQR = gsl_matrix_view_array(L->data, p, m);
gsl_matrix *LT = gsl_matrix_alloc(p, m);
/* XXX: use temporary storage due to difficulties in transforming
* a rectangular matrix in-place */
gsl_matrix_transpose_memcpy(LT, L);
gsl_matrix_memcpy(<QR.matrix, LT);
gsl_matrix_free(LT);
status = gsl_linalg_QR_decomp(<QR.matrix, tau);
return status;
}
}
/* compute compact QR factorization
M is mxn; Q is mxk and R is kxk
*/
void compute_QR_compact_factorization(gsl_matrix *M, gsl_matrix *Q, gsl_matrix *R){
int i,j,m,n,k;
m = M->size1;
n = M->size2;
k = min(m,n);
//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("extract R..\n");
for(i=0; i<k; i++){
for(j=0; j<k; j++){
if(j>=i){
gsl_matrix_set(R,i,j,gsl_matrix_get(QR,i,j));
}
}
}
//printf("extract Q..\n");
gsl_vector *vj = gsl_vector_calloc(m);
for(j=0; j<k; j++){
gsl_vector_set(vj,j,1.0);
gsl_linalg_QR_Qvec (QR, tau, vj);
gsl_matrix_set_col(Q,j,vj);
vj = gsl_vector_calloc(m);
}
}
/*affects a! so we might need to clone a. This is just a wrapper of GSL function
the result is stored in a and tau.*/
inline void qr_coded(double* a, double* tau, int m,int 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_decomp(&av.matrix,&tv.vector);
}
/* Returns the R matrix of a QR factorization. */
static gsl_matrix *qr_fact(struct mvar_fit *fit, gsl_vector *scale)
{
gsl_matrix *R, *K, *K_diag;
gsl_vector *tau;
double delta;
K = data_mat_K(fit);
delta = (pow(K->size2, 2) + K->size2 + 1) * GSL_DBL_EPSILON;
mvar_mat_sum_sq_sqrt(K, scale);
gsl_vector_scale(scale, sqrt(delta));
K_diag = gsl_matrix_alloc(scale->size, scale->size);
gsl_matrix_set_all(K_diag, 0.0);
mvar_mat_set_diag(K_diag, scale);
/* Combine the rows of K and K_diag into one big matrix R, which is then QR decomposed. */
R = gsl_matrix_alloc(K->size1 + scale->size, K->size2);
gsl_matrix_set_all(R, 0.0);
mvar_mat_copy(R, K, 0, 0);
mvar_mat_copy(R, K_diag, K->size1, 0);
tau = gsl_vector_alloc(R->size2);
gsl_linalg_QR_decomp(R, tau);
mvar_mat_upper_tri(R);
gsl_matrix_free(K);
gsl_vector_free(tau);
gsl_matrix_free(K_diag);
return R;
}
/* compute compact QR factorization and get Q
M is mxn; Q is mxk and R is kxk (not computed)
*/
void QR_factorization_getQ(gsl_matrix *M, gsl_matrix *Q){
int i,j,m,n,k;
m = M->size1;
n = M->size2;
k = min(m,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);
gsl_linalg_QR_decomp (QR, tau);
gsl_vector *vj = gsl_vector_calloc(m);
for(j=0; j<k; j++){
gsl_vector_set(vj,j,1.0);
gsl_linalg_QR_Qvec (QR, tau, vj);
gsl_matrix_set_col(Q,j,vj);
vj = gsl_vector_calloc(m);
}
gsl_vector_free(vj);
gsl_vector_free(tau);
gsl_matrix_free(QR);
}
/* QR decomposition */
CAMLprim value ml_gsl_linalg_QR_decomp(value A, value TAU)
{
_DECLARE_MATRIX(A);
_DECLARE_VECTOR(TAU);
_CONVERT_MATRIX(A);
_CONVERT_VECTOR(TAU);
gsl_linalg_QR_decomp(&m_A, &v_TAU);
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);
}
int gslutils_solve_leastsquares(gsl_matrix* A, gsl_vector** B,
gsl_vector** X, gsl_vector** resids,
int NB) {
int i;
gsl_vector *tau, *resid = NULL;
Unused int ret;
int M, N;
M = A->size1;
N = A->size2;
for (i=0; i<NB; i++) {
assert(B[i]);
assert(B[i]->size == M);
}
tau = gsl_vector_alloc(MIN(M, N));
assert(tau);
ret = gsl_linalg_QR_decomp(A, tau);
assert(ret == 0);
// A,tau now contains a packed version of Q,R.
for (i=0; i<NB; i++) {
if (!resid) {
resid = gsl_vector_alloc(M);
assert(resid);
}
X[i] = gsl_vector_alloc(N);
assert(X[i]);
ret = gsl_linalg_QR_lssolve(A, tau, B[i], X[i], resid);
assert(ret == 0);
if (resids) {
resids[i] = resid;
resid = NULL;
}
}
gsl_vector_free(tau);
if (resid)
gsl_vector_free(resid);
return 0;
}
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_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;
}
}
}
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 Matrix::factorizeQR ( Vector& tau ) {
gsl_linalg_QR_decomp( &matrix, &tau.vector );
}
double integral_generalized_sing(gsl_function f, double a, double b, double y, int n, int m, double *x_gauss, double *w_gauss, double*x, double *w)
{
gsl_vector *rhs,*soln,*tau,*res;
gsl_matrix *A;
double *w1,*w2,*w3,*x1,*x2,*x3,*x_t;
gsl_function f_temp;
pl_params p;
double y_scaled,x_mid,x_halflength,integral;
int i,j;
x_mid = (b+a)/2.0;
x_halflength = (b-a)/2.0;
/*scale y to -1 to 1*/
y_scaled = (1/x_halflength)*y - (x_mid/x_halflength);
/*allocate memory for aux. quadrature weight calculations*/
w1 = (double *)malloc((n+1)*sizeof(double));
w2 = (double *)malloc((n+1)*sizeof(double));
w3 = (double *)malloc((n+1)*sizeof(double));
x1 = (double *)malloc((n+1)*sizeof(double));
x2 = (double *)malloc((n+1)*sizeof(double));
x3 = (double *)malloc((n+1)*sizeof(double));
x_t = (double *)malloc((n+1)*sizeof(double));
/*allocate memory for system matrix rhs vector and solution vector along with
vector of householder coeffs*/
rhs = gsl_vector_calloc(4*m);
res = gsl_vector_calloc(4*m);
soln = gsl_vector_calloc(n);
/*Note that here we assume that 4*m > n*/
tau = gsl_vector_calloc(n);
A = gsl_matrix_calloc(4*m,n);
/*fill in the entries of the matrix*/
for(i=0;i<n;i++)
{
for(j=0;j<m;j++)
{
gsl_matrix_set(A,j,i,legendre_poly(j,x_gauss[i+1]));
gsl_matrix_set(A,j+m,i,legendre_poly(j,x_gauss[i+1])*log(fabs(y_scaled - x_gauss[i+1])));
gsl_matrix_set(A,j+(2*m),i,legendre_poly(j,x_gauss[i+1])*(1/(y_scaled - x_gauss[i+1])));
gsl_matrix_set(A,j+(3*m),i,legendre_poly(j,x_gauss[i+1])*(1/((y_scaled - x_gauss[i+1])*(y_scaled - x_gauss[i+1]))));
}
}
/*calculate quadrature points for the exact evaluation of the integrals of the various
phi functions */
quad_log_singularity_half(y_scaled, n, x_gauss, w_gauss, x1, w1);
quad_x_singularity(y_scaled, n, x_gauss, w_gauss, x2, w2);
quad_x2_singularity(y_scaled, n, x_gauss, w_gauss, x3, w3);
/*fill in the rhs vector*/
for(i=0;i<m;i++)
{
p.deg = i;
f_temp.function = &func_legendre_pl;
f_temp.params = &p;
gsl_vector_set(rhs,i,integral_gaussleg(f_temp,-1.0,1.0,n,x_gauss,w_gauss));
gsl_vector_set(rhs,i+m,integral_gauss_log_sing(f_temp,-1.0,1.0,y_scaled,n,x_gauss,w_gauss,x1,w1));
gsl_vector_set(rhs,i+(2*m),integral_gauss_x_sing(f_temp,-1.0,1.0,y_scaled,n,x_gauss,w_gauss,x2,w2));
gsl_vector_set(rhs,i+(3*m),integral_gauss_x2_sing(f_temp,-1.0,1.0,y_scaled,n,x_gauss,w_gauss,x3,w3));
}
/*solve the linear system in the least squares sense*/
gsl_linalg_QR_decomp(A,tau);
gsl_linalg_QR_lssolve(A,tau,rhs,soln,res);
for(i=0;i<n;i++)
{
w[i+1] = gsl_vector_get(soln,i);
x[i+1] = x_gauss[i+1];
}
/*integrate*/
for(i=1;i<=n;i++)
{
x_t[i] = x_halflength*x[i] + x_mid;
}
integral = 0;
for(i=1;i<=n;i++)
{
integral = integral + (w[i]*(*(f.function))(x_t[i],f.params));
}
integral = x_halflength*integral;
/*free allocated memory*/
free(x1);
free(x2);
free(x3);
free(w1);
free(w2);
free(w3);
free(x_t);
gsl_vector_free(rhs);
gsl_vector_free(soln);
gsl_vector_free(tau);
gsl_vector_free(res);
gsl_matrix_free(A);
return integral;
}
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
gsl_bspline_knots_greville (const gsl_vector *abscissae,
gsl_bspline_workspace *w,
double *abserr)
{
int s;
/* Check incoming arguments satisfy mandatory algorithmic assumptions */
if (w->k < 2)
GSL_ERROR ("w->k must be at least 2", GSL_EINVAL);
else if (abscissae->size < 2)
GSL_ERROR ("abscissae->size must be at least 2", GSL_EINVAL);
else if (w->nbreak != abscissae->size - w->k + 2)
GSL_ERROR ("w->nbreak must equal abscissae->size - w->k + 2", GSL_EINVAL);
if (w->nbreak == 2)
{
/* No flexibility in abscissae values possible in this degenerate case */
s = gsl_bspline_knots_uniform (
gsl_vector_get (abscissae, 0),
gsl_vector_get (abscissae, abscissae->size - 1), w);
}
else
{
double * storage;
gsl_matrix_view A;
gsl_vector_view tau, b, x, r;
size_t i, j;
/* Constants derived from the B-spline workspace and abscissae details */
const size_t km2 = w->k - 2;
const size_t M = abscissae->size - 2;
const size_t N = w->nbreak - 2;
const double invkm1 = 1.0 / w->km1;
/* Allocate working storage and prepare multiple, zero-filled views */
storage = (double *) calloc (M*N + 2*N + 2*M, sizeof (double));
if (storage == 0)
GSL_ERROR ("failed to allocate working storage", GSL_ENOMEM);
A = gsl_matrix_view_array (storage, M, N);
tau = gsl_vector_view_array (storage + M*N, N);
b = gsl_vector_view_array (storage + M*N + N, M);
x = gsl_vector_view_array (storage + M*N + N + M, N);
r = gsl_vector_view_array (storage + M*N + N + M + N, M);
/* Build matrix from interior breakpoints to interior Greville abscissae.
* For example, when w->k = 4 and w->nbreak = 7 the matrix is
* [ 1, 0, 0, 0, 0;
* 2/3, 1/3, 0, 0, 0;
* 1/3, 1/3, 1/3, 0, 0;
* 0, 1/3, 1/3, 1/3, 0;
* 0, 0, 1/3, 1/3, 1/3;
* 0, 0, 0, 1/3, 2/3;
* 0, 0, 0, 0, 1 ]
* but only center formed as first/last breakpoint is known.
*/
for (j = 0; j < N; ++j)
for (i = 0; i <= km2; ++i)
gsl_matrix_set (&A.matrix, i+j, j, invkm1);
/* Copy interior collocation points from abscissae into b */
for (i = 0; i < M; ++i)
gsl_vector_set (&b.vector, i, gsl_vector_get (abscissae, i+1));
/* Adjust b to account for constraint columns not stored in A */
for (i = 0; i < km2; ++i)
{
double * const v = gsl_vector_ptr (&b.vector, i);
*v -= (1 - (i+1)*invkm1) * gsl_vector_get (abscissae, 0);
}
for (i = 0; i < km2; ++i)
{
double * const v = gsl_vector_ptr (&b.vector, M - km2 + i);
*v -= (i+1)*invkm1 * gsl_vector_get (abscissae, abscissae->size - 1);
}
/* Perform linear least squares to determine interior breakpoints */
s = gsl_linalg_QR_decomp (&A.matrix, &tau.vector)
|| gsl_linalg_QR_lssolve (&A.matrix, &tau.vector,
&b.vector, &x.vector, &r.vector);
if (s)
{
free (storage);
return s;
}
/* "Expand" solution x by adding known first and last breakpoints. */
x = gsl_vector_view_array_with_stride (
gsl_vector_ptr (&x.vector, 0) - x.vector.stride,
x.vector.stride, x.vector.size + 2);
gsl_vector_set (&x.vector, 0, gsl_vector_get (abscissae, 0));
gsl_vector_set (&x.vector, x.vector.size - 1,
gsl_vector_get (abscissae, abscissae->size - 1));
/* Finally, initialize workspace knots using the now-known breakpoints */
s = gsl_bspline_knots (&x.vector, w);
free (storage);
}
/* Sum absolute errors in the resulting vs requested interior abscissae */
/* Provided as a fit quality metric which may be monitored by callers */
if (!s && abserr)
{
size_t i;
*abserr = 0;
for (i = 1; i < abscissae->size - 1; ++i)
*abserr += fabs ( gsl_bspline_greville_abscissa (i, w)
- gsl_vector_get (abscissae, i) );
}
return s;
}
int main(int argc, char **argv) {
gsl_rng *rng;
gsl_rng_env_setup();
const gsl_rng_type *rngType = gsl_rng_default;
rng = gsl_rng_alloc(rngType);
const size_t M = SIZE1;
const size_t N = SIZE2;
gsl_matrix *A = gsl_matrix_alloc(M, N);
int i = 0;
int j = 0;
int sigNum = 0;
for (i = 0; i < M; i++) {
for (j = 0; j < N; j++) {
gsl_matrix_set(A, i, j, gsl_ran_ugaussian(rng));
}
}
gsl_matrix *B = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(B, A);
gsl_matrix *C = gsl_matrix_alloc(M, N);
gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, A, B, 0.0, C);
gsl_matrix *D = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(D, C); // will be used in QTQ' decompostion
gsl_linalg_cholesky_decomp(C);
printf("%e\n", gsl_matrix_get(C, M/2, N/2));
gsl_matrix_free(B);
gsl_matrix *A1 = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(A1, A);
gsl_permutation *P = gsl_permutation_alloc(M); // will be used in
// other cases
gsl_permutation_init(P);
gsl_ran_shuffle (rng, P->data, M, sizeof(size_t));
gsl_linalg_LU_decomp(A1, P, &sigNum);
printf("%e\n", gsl_matrix_get(A1, M/2, N/2));
gsl_matrix *A2 = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(A2, A);
gsl_vector *tau = gsl_vector_alloc(GSL_MIN(M, N));
gsl_linalg_QR_decomp(A2, tau);
printf("%e\n", gsl_matrix_get(A2, M/2, N/2));
gsl_vector_free(tau);
gsl_matrix *A3 = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(A3, A);
gsl_matrix *svdV = gsl_matrix_alloc(N, N);
gsl_vector *svdS = gsl_vector_alloc(N);
gsl_vector *svdWorkspace = gsl_vector_alloc(N);
gsl_linalg_SV_decomp(A3, svdV, svdS, svdWorkspace);
printf("%e\n", gsl_vector_get(svdS, N/2));
gsl_vector *tau2 = gsl_vector_alloc(N - 1);
gsl_linalg_symmtd_decomp(D, tau2);
printf("%e\n", gsl_matrix_get(D, N/2, N/2));
return 0;
}
/**
* \brief A variant of the Savitzky-Golay algorithm able to handle non-uniformly distributed data.
*
* In comparison to smoothSavGol(), this method trades proper handling of the X coordinates for
* runtime efficiency by abandoning a central idea of Savitzky-Golay algorithm, namely that
* polynomial smoothing can be expressed as a convolution.
*
* TODO: integrate this option into the GUI.
*/
void SmoothFilter::smoothModifiedSavGol(double *x_in, double *y_inout)
{
// total number of points in smoothing window
int points = d_left_points + d_right_points + 1;
if (points < d_polynom_order+1) {
QMessageBox::critical((ApplicationWindow *)parent(), tr("SciDAVis") + " - " + tr("Error"),
tr("The polynomial order must be lower than the number of left points plus the number of right points!"));
return;
}
// allocate memory for the result
QVector<double> result(d_n);
// allocate memory for the linear algegra computations
// Vandermonde matrix for x values of points in the current smoothing window
gsl_matrix *vandermonde = gsl_matrix_alloc(points, d_polynom_order+1);
// stores part of the QR decomposition of vandermonde
gsl_vector *tau = gsl_vector_alloc(qMin(points, d_polynom_order+1));
// coefficients of polynomial approximation computed for each smoothing window
gsl_vector *poly = gsl_vector_alloc(d_polynom_order+1);
// residual of the (least-squares) approximation (by-product of GSL's algorithm)
gsl_vector *residual = gsl_vector_alloc(points);
for (int target_index = 0; target_index < d_n; target_index++) {
int offset = target_index - d_left_points;
// use a fixed number of points; near left/right borders, use offset to change
// effective number of left/right points considered
if (target_index < d_left_points)
offset += d_left_points - target_index;
else if (target_index + d_right_points >= d_n)
offset += d_n - 1 - (target_index + d_right_points);
// fill Vandermonde matrix
for (int i = 0; i < points; ++i) {
gsl_matrix_set(vandermonde, i, 0, 1.0);
for (int j = 1; j <= d_polynom_order; ++j)
gsl_matrix_set(vandermonde, i, j, gsl_matrix_get(vandermonde,i,j-1) * x_in[offset + i]);
}
// Y values within current smoothing window
gsl_vector_view y_slice = gsl_vector_view_array(y_inout+offset, points);
// compute QR decomposition of Vandermonde matrix
if (int error=gsl_linalg_QR_decomp(vandermonde, tau))
QMessageBox::critical((ApplicationWindow *)parent(), tr("SciDAVis") + " - " + tr("Error"),
tr("Internal error in Savitzky-Golay algorithm: QR decomposition failed.\n")
+ gsl_strerror(error));
// least-squares-solve vandermonde*poly=y_slice using the QR decomposition now stored in
// vandermonde and tau
else if (int error=gsl_linalg_QR_lssolve(vandermonde, tau, &y_slice.vector, poly, residual))
QMessageBox::critical((ApplicationWindow *)parent(), tr("SciDAVis") + " - " + tr("Error"),
tr("Internal error in Savitzky-Golay algorithm: least-squares solution failed.\n")
+ gsl_strerror(error));
else
result[target_index] = gsl_poly_eval(poly->data, d_polynom_order+1, x_in[target_index]);
}
// deallocate memory
gsl_vector_free(residual);
gsl_vector_free(poly);
gsl_vector_free(tau);
gsl_matrix_free(vandermonde);
// write result into *y_inout
qCopy(result.begin(), result.end(), y_inout);
}
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() */
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;
}
/**
* C++ version of gsl_linalg_QR_decomp().
* @param A A matrix
* @param tau A vector
* @return Error code on failure
*/
inline int QR_decomp( matrix& A, vector& tau ){ return gsl_linalg_QR_decomp( A.get(), tau.get() ); }
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);
}
