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); }