int lsQRPT(gsl_matrix * A, gsl_vector * b, gsl_vector * x, double * sigma)
{
int i;
gsl_vector *tau, *res;
gsl_permutation *p;
gsl_vector_view norm;
if (A->size1 < A->size2) return -1;
if (A->size1 != b->size) return -1;
if (A->size2 != x->size) return -1;
tau = gsl_vector_alloc(x->size);
res = gsl_vector_alloc(b->size);
p = gsl_permutation_alloc(x->size);
norm = gsl_vector_subvector(res, 0, x->size);
gsl_linalg_QRPT_decomp(A, tau, p, &i, &norm.vector);
gsl_linalg_QR_lssolve(A, tau, b, x, res);
gsl_permute_vector_inverse(p, x);
*sigma = gsl_blas_dnrm2(res);
gsl_vector_free(tau);
gsl_vector_free(res);
gsl_permutation_free(p);
return 0;
}
CAMLprim value ml_gsl_linalg_QR_lssolve(value QR, value TAU, value B, value X,
value RES)
{
_DECLARE_MATRIX(QR);
_DECLARE_VECTOR4(TAU, RES, B, X);
_CONVERT_MATRIX(QR);
_CONVERT_VECTOR4(TAU, RES, B, X);
gsl_linalg_QR_lssolve(&m_QR, &v_TAU, &v_B, &v_X, &v_RES);
return Val_unit;
}
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;
}
/**
* C++ version of gsl_linalg_QR_lssolve().
* @param QR A QR decomposition
* @param tau A vector
* @param b A vector
* @param x A vector
* @param residual A residual vector
* @return Error code on failure
*/
inline int QR_lssolve( matrix const& QR, vector const& tau, vector const& b, vector& x,
vector& residual ){
return gsl_linalg_QR_lssolve( QR.get(), tau.get(), b.get(), x.get(), residual.get() ); }
/**
* \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_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;
}
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;
}
