/************************************************************************* Returns True for successful test, False - for failed test *************************************************************************/ static bool testrmatrixrcond(int maxn, int passcount) { bool result; ap::real_2d_array a; ap::real_2d_array lua; ap::integer_1d_array p; int n; int i; int j; int pass; bool err50; bool err90; bool errspec; bool errless; double erc1; double ercinf; ap::real_1d_array q50; ap::real_1d_array q90; double v; err50 = false; err90 = false; errless = false; errspec = false; q50.setbounds(0, 3); q90.setbounds(0, 3); for(n = 1; n <= maxn; n++) { // // special test for zero matrix // rmatrixgenzero(a, n); rmatrixmakeacopy(a, n, n, lua); rmatrixlu(lua, n, n, p); errspec = errspec||ap::fp_neq(rmatrixrcond1(a, n),0); errspec = errspec||ap::fp_neq(rmatrixrcondinf(a, n),0); errspec = errspec||ap::fp_neq(rmatrixlurcond1(lua, n),0); errspec = errspec||ap::fp_neq(rmatrixlurcondinf(lua, n),0); // // general test // a.setbounds(0, n-1, 0, n-1); for(i = 0; i <= 3; i++) { q50(i) = 0; q90(i) = 0; } for(pass = 1; pass <= passcount; pass++) { rmatrixrndcond(n, exp(ap::randomreal()*log(double(1000))), a); rmatrixmakeacopy(a, n, n, lua); rmatrixlu(lua, n, n, p); rmatrixrefrcond(a, n, erc1, ercinf); // // 1-norm, normal // v = 1/rmatrixrcond1(a, n); if( ap::fp_greater_eq(v,threshold50*erc1) ) { q50(0) = q50(0)+double(1)/double(passcount); } if( ap::fp_greater_eq(v,threshold90*erc1) ) { q90(0) = q90(0)+double(1)/double(passcount); } errless = errless||ap::fp_greater(v,erc1*1.001); // // 1-norm, LU // v = 1/rmatrixlurcond1(lua, n); if( ap::fp_greater_eq(v,threshold50*erc1) ) { q50(1) = q50(1)+double(1)/double(passcount); } if( ap::fp_greater_eq(v,threshold90*erc1) ) { q90(1) = q90(1)+double(1)/double(passcount); } errless = errless||ap::fp_greater(v,erc1*1.001); // // Inf-norm, normal // v = 1/rmatrixrcondinf(a, n); if( ap::fp_greater_eq(v,threshold50*ercinf) ) { q50(2) = q50(2)+double(1)/double(passcount); } if( ap::fp_greater_eq(v,threshold90*ercinf) ) { q90(2) = q90(2)+double(1)/double(passcount); } errless = errless||ap::fp_greater(v,ercinf*1.001); // // Inf-norm, LU // v = 1/rmatrixlurcondinf(lua, n); if( ap::fp_greater_eq(v,threshold50*ercinf) ) { q50(3) = q50(3)+double(1)/double(passcount); } if( ap::fp_greater_eq(v,threshold90*ercinf) ) { q90(3) = q90(3)+double(1)/double(passcount); } errless = errless||ap::fp_greater(v,ercinf*1.001); } for(i = 0; i <= 3; i++) { err50 = err50||ap::fp_less(q50(i),0.50); err90 = err90||ap::fp_less(q90(i),0.90); } // // degenerate matrix test // if( n>=3 ) { a.setlength(n, n); for(i = 0; i <= n-1; i++) { for(j = 0; j <= n-1; j++) { a(i,j) = 0.0; } } a(0,0) = 1; a(n-1,n-1) = 1; errspec = errspec||ap::fp_neq(rmatrixrcond1(a, n),0); errspec = errspec||ap::fp_neq(rmatrixrcondinf(a, n),0); errspec = errspec||ap::fp_neq(rmatrixlurcond1(a, n),0); errspec = errspec||ap::fp_neq(rmatrixlurcondinf(a, n),0); } // // near-degenerate matrix test // if( n>=2 ) { a.setlength(n, n); for(i = 0; i <= n-1; i++) { for(j = 0; j <= n-1; j++) { a(i,j) = 0.0; } } for(i = 0; i <= n-1; i++) { a(i,i) = 1; } i = ap::randominteger(n); a(i,i) = 0.1*ap::maxrealnumber; errspec = errspec||ap::fp_neq(rmatrixrcond1(a, n),0); errspec = errspec||ap::fp_neq(rmatrixrcondinf(a, n),0); errspec = errspec||ap::fp_neq(rmatrixlurcond1(a, n),0); errspec = errspec||ap::fp_neq(rmatrixlurcondinf(a, n),0); } } // // report // result = !(err50||err90||errless||errspec); return result; }
/************************************************************************* Weighted constained linear least squares fitting. This is variation of LSFitLinearW(), which searchs for min|A*x=b| given that K additional constaints C*x=bc are satisfied. It reduces original task to modified one: min|B*y-d| WITHOUT constraints, then LSFitLinearW() is called. INPUT PARAMETERS: Y - array[0..N-1] Function values in N points. W - array[0..N-1] Weights corresponding to function values. Each summand in square sum of approximation deviations from given values is multiplied by the square of corresponding weight. FMatrix - a table of basis functions values, array[0..N-1, 0..M-1]. FMatrix[I,J] - value of J-th basis function in I-th point. CMatrix - a table of constaints, array[0..K-1,0..M]. I-th row of CMatrix corresponds to I-th linear constraint: CMatrix[I,0]*C[0] + ... + CMatrix[I,M-1]*C[M-1] = CMatrix[I,M] N - number of points used. N>=1. M - number of basis functions, M>=1. K - number of constraints, 0 <= K < M K=0 corresponds to absence of constraints. OUTPUT PARAMETERS: Info - error code: * -4 internal SVD decomposition subroutine failed (very rare and for degenerate systems only) * -3 either too many constraints (M or more), degenerate constraints (some constraints are repetead twice) or inconsistent constraints were specified. * -1 incorrect N/M/K were specified * 1 task is solved C - decomposition coefficients, array[0..M-1] Rep - fitting report. Following fields are set: * RMSError rms error on the (X,Y). * AvgError average error on the (X,Y). * AvgRelError average relative error on the non-zero Y * MaxError maximum error NON-WEIGHTED ERRORS ARE CALCULATED IMPORTANT: this subroitine doesn't calculate task's condition number for K<>0. SEE ALSO LSFitLinear LSFitLinearC LSFitLinearWC -- ALGLIB -- Copyright 07.09.2009 by Bochkanov Sergey *************************************************************************/ void lsfitlinearwc(ap::real_1d_array y, const ap::real_1d_array& w, const ap::real_2d_array& fmatrix, ap::real_2d_array cmatrix, int n, int m, int k, int& info, ap::real_1d_array& c, lsfitreport& rep) { int i; int j; ap::real_1d_array tau; ap::real_2d_array q; ap::real_2d_array f2; ap::real_1d_array tmp; ap::real_1d_array c0; double v; if( n<1||m<1||k<0 ) { info = -1; return; } if( k>=m ) { info = -3; return; } // // Solve // if( k==0 ) { // // no constraints // lsfitlinearinternal(y, w, fmatrix, n, m, info, c, rep); } else { // // First, find general form solution of constraints system: // * factorize C = L*Q // * unpack Q // * fill upper part of C with zeros (for RCond) // // We got C=C0+Q2'*y where Q2 is lower M-K rows of Q. // rmatrixlq(cmatrix, k, m, tau); rmatrixlqunpackq(cmatrix, k, m, tau, m, q); for(i = 0; i <= k-1; i++) { for(j = i+1; j <= m-1; j++) { cmatrix(i,j) = 0.0; } } if( ap::fp_less(rmatrixlurcondinf(cmatrix, k),1000*ap::machineepsilon) ) { info = -3; return; } tmp.setlength(k); for(i = 0; i <= k-1; i++) { if( i>0 ) { v = ap::vdotproduct(&cmatrix(i, 0), 1, &tmp(0), 1, ap::vlen(0,i-1)); } else { v = 0; } tmp(i) = (cmatrix(i,m)-v)/cmatrix(i,i); } c0.setlength(m); for(i = 0; i <= m-1; i++) { c0(i) = 0; } for(i = 0; i <= k-1; i++) { v = tmp(i); ap::vadd(&c0(0), 1, &q(i, 0), 1, ap::vlen(0,m-1), v); } // // Second, prepare modified matrix F2 = F*Q2' and solve modified task // tmp.setlength(ap::maxint(n, m)+1); f2.setlength(n, m-k); matrixvectormultiply(fmatrix, 0, n-1, 0, m-1, false, c0, 0, m-1, -1.0, y, 0, n-1, 1.0); matrixmatrixmultiply(fmatrix, 0, n-1, 0, m-1, false, q, k, m-1, 0, m-1, true, 1.0, f2, 0, n-1, 0, m-k-1, 0.0, tmp); lsfitlinearinternal(y, w, f2, n, m-k, info, tmp, rep); rep.taskrcond = -1; if( info<=0 ) { return; } // // then, convert back to original answer: C = C0 + Q2'*Y0 // c.setlength(m); ap::vmove(&c(0), 1, &c0(0), 1, ap::vlen(0,m-1)); matrixvectormultiply(q, k, m-1, 0, m-1, true, tmp, 0, m-k-1, 1.0, c, 0, m-1, 1.0); } }
/************************************************************************* Dense solver. This subroutine solves a system A*X=B, where A is NxN non-denegerate real matrix, X and B are NxM real matrices. Additional features include: * automatic detection of degenerate cases * iterative improvement INPUT PARAMETERS A - array[0..N-1,0..N-1], system matrix N - size of A B - array[0..N-1,0..M-1], right part M - size of right part OUTPUT PARAMETERS Info - return code: * -3 if A is singular, or VERY close to singular. X is filled by zeros in such cases. * -1 if N<=0 or M<=0 was passed * 1 if task is solved (matrix A may be near singular, check R1/RInf parameters for condition numbers). Rep - solver report, see below for more info X - array[0..N-1,0..M-1], it contains: * solution of A*X=B if A is non-singular (well-conditioned or ill-conditioned, but not very close to singular) * zeros, if A is singular or VERY close to singular (in this case Info=-3). SOLVER REPORT Subroutine sets following fields of the Rep structure: * R1 reciprocal of condition number: 1/cond(A), 1-norm. * RInf reciprocal of condition number: 1/cond(A), inf-norm. SEE ALSO: DenseSolverR() - solves A*x = b, where x and b are Nx1 matrices. -- ALGLIB -- Copyright 24.08.2009 by Bochkanov Sergey *************************************************************************/ void rmatrixsolvem(const ap::real_2d_array& a, int n, const ap::real_2d_array& b, int m, int& info, densesolverreport& rep, ap::real_2d_array& x) { int i; int j; int k; int rfs; int nrfs; ap::integer_1d_array p; ap::real_1d_array xc; ap::real_1d_array y; ap::real_1d_array bc; ap::real_1d_array xa; ap::real_1d_array xb; ap::real_1d_array tx; ap::real_2d_array da; double v; double verr; bool smallerr; bool terminatenexttime; // // prepare: check inputs, allocate space... // if( n<=0||m<=0 ) { info = -1; return; } da.setlength(n, n); x.setlength(n, m); y.setlength(n); xc.setlength(n); bc.setlength(n); tx.setlength(n+1); xa.setlength(n+1); xb.setlength(n+1); // // factorize matrix, test for exact/near singularity // for(i = 0; i <= n-1; i++) { ap::vmove(&da(i, 0), &a(i, 0), ap::vlen(0,n-1)); } rmatrixlu(da, n, n, p); rep.r1 = rmatrixlurcond1(da, n); rep.rinf = rmatrixlurcondinf(da, n); if( ap::fp_less(rep.r1,10*ap::machineepsilon)||ap::fp_less(rep.rinf,10*ap::machineepsilon) ) { for(i = 0; i <= n-1; i++) { for(j = 0; j <= m-1; j++) { x(i,j) = 0; } } rep.r1 = 0; rep.rinf = 0; info = -3; return; } info = 1; // // solve // for(k = 0; k <= m-1; k++) { // // First, non-iterative part of solution process: // * pivots // * L*y = b // * U*x = y // ap::vmove(bc.getvector(0, n-1), b.getcolumn(k, 0, n-1)); for(i = 0; i <= n-1; i++) { if( p(i)!=i ) { v = bc(i); bc(i) = bc(p(i)); bc(p(i)) = v; } } y(0) = bc(0); for(i = 1; i <= n-1; i++) { v = ap::vdotproduct(&da(i, 0), &y(0), ap::vlen(0,i-1)); y(i) = bc(i)-v; } xc(n-1) = y(n-1)/da(n-1,n-1); for(i = n-2; i >= 0; i--) { v = ap::vdotproduct(&da(i, i+1), &xc(i+1), ap::vlen(i+1,n-1)); xc(i) = (y(i)-v)/da(i,i); } // // Iterative improvement of xc: // * calculate r = bc-A*xc using extra-precise dot product // * solve A*y = r // * update x:=x+r // // This cycle is executed until one of two things happens: // 1. maximum number of iterations reached // 2. last iteration decreased error to the lower limit // nrfs = densesolverrfsmax(n, rep.r1, rep.rinf); terminatenexttime = false; for(rfs = 0; rfs <= nrfs-1; rfs++) { if( terminatenexttime ) { break; } // // generate right part // smallerr = true; for(i = 0; i <= n-1; i++) { ap::vmove(&xa(0), &a(i, 0), ap::vlen(0,n-1)); xa(n) = -1; ap::vmove(&xb(0), &xc(0), ap::vlen(0,n-1)); xb(n) = b(i,k); xdot(xa, xb, n+1, tx, v, verr); bc(i) = -v; smallerr = smallerr&&ap::fp_less(fabs(v),4*verr); } if( smallerr ) { terminatenexttime = true; } // // solve // for(i = 0; i <= n-1; i++) { if( p(i)!=i ) { v = bc(i); bc(i) = bc(p(i)); bc(p(i)) = v; } } y(0) = bc(0); for(i = 1; i <= n-1; i++) { v = ap::vdotproduct(&da(i, 0), &y(0), ap::vlen(0,i-1)); y(i) = bc(i)-v; } tx(n-1) = y(n-1)/da(n-1,n-1); for(i = n-2; i >= 0; i--) { v = ap::vdotproduct(&da(i, i+1), &tx(i+1), ap::vlen(i+1,n-1)); tx(i) = (y(i)-v)/da(i,i); } // // update // ap::vadd(&xc(0), &tx(0), ap::vlen(0,n-1)); } // // Store xc // ap::vmove(x.getcolumn(k, 0, n-1), xc.getvector(0, n-1)); } }
/************************************************************************* Internal fitting subroutine *************************************************************************/ static void lsfitlinearinternal(const ap::real_1d_array& y, const ap::real_1d_array& w, const ap::real_2d_array& fmatrix, int n, int m, int& info, ap::real_1d_array& c, lsfitreport& rep) { double threshold; ap::real_2d_array ft; ap::real_2d_array q; ap::real_2d_array l; ap::real_2d_array r; ap::real_1d_array b; ap::real_1d_array wmod; ap::real_1d_array tau; int i; int j; double v; ap::real_1d_array sv; ap::real_2d_array u; ap::real_2d_array vt; ap::real_1d_array tmp; ap::real_1d_array utb; ap::real_1d_array sutb; int relcnt; if( n<1||m<1 ) { info = -1; return; } info = 1; threshold = sqrt(ap::machineepsilon); // // Degenerate case, needs special handling // if( n<m ) { // // Create design matrix. // ft.setlength(n, m); b.setlength(n); wmod.setlength(n); for(j = 0; j <= n-1; j++) { v = w(j); ap::vmove(&ft(j, 0), 1, &fmatrix(j, 0), 1, ap::vlen(0,m-1), v); b(j) = w(j)*y(j); wmod(j) = 1; } // // LQ decomposition and reduction to M=N // c.setlength(m); for(i = 0; i <= m-1; i++) { c(i) = 0; } rep.taskrcond = 0; rmatrixlq(ft, n, m, tau); rmatrixlqunpackq(ft, n, m, tau, n, q); rmatrixlqunpackl(ft, n, m, l); lsfitlinearinternal(b, wmod, l, n, n, info, tmp, rep); if( info<=0 ) { return; } for(i = 0; i <= n-1; i++) { v = tmp(i); ap::vadd(&c(0), 1, &q(i, 0), 1, ap::vlen(0,m-1), v); } return; } // // N>=M. Generate design matrix and reduce to N=M using // QR decomposition. // ft.setlength(n, m); b.setlength(n); for(j = 0; j <= n-1; j++) { v = w(j); ap::vmove(&ft(j, 0), 1, &fmatrix(j, 0), 1, ap::vlen(0,m-1), v); b(j) = w(j)*y(j); } rmatrixqr(ft, n, m, tau); rmatrixqrunpackq(ft, n, m, tau, m, q); rmatrixqrunpackr(ft, n, m, r); tmp.setlength(m); for(i = 0; i <= m-1; i++) { tmp(i) = 0; } for(i = 0; i <= n-1; i++) { v = b(i); ap::vadd(&tmp(0), 1, &q(i, 0), 1, ap::vlen(0,m-1), v); } b.setlength(m); ap::vmove(&b(0), 1, &tmp(0), 1, ap::vlen(0,m-1)); // // R contains reduced MxM design upper triangular matrix, // B contains reduced Mx1 right part. // // Determine system condition number and decide // should we use triangular solver (faster) or // SVD-based solver (more stable). // // We can use LU-based RCond estimator for this task. // rep.taskrcond = rmatrixlurcondinf(r, m); if( ap::fp_greater(rep.taskrcond,threshold) ) { // // use QR-based solver // c.setlength(m); c(m-1) = b(m-1)/r(m-1,m-1); for(i = m-2; i >= 0; i--) { v = ap::vdotproduct(&r(i, i+1), 1, &c(i+1), 1, ap::vlen(i+1,m-1)); c(i) = (b(i)-v)/r(i,i); } } else { // // use SVD-based solver // if( !rmatrixsvd(r, m, m, 1, 1, 2, sv, u, vt) ) { info = -4; return; } utb.setlength(m); sutb.setlength(m); for(i = 0; i <= m-1; i++) { utb(i) = 0; } for(i = 0; i <= m-1; i++) { v = b(i); ap::vadd(&utb(0), 1, &u(i, 0), 1, ap::vlen(0,m-1), v); } if( ap::fp_greater(sv(0),0) ) { rep.taskrcond = sv(m-1)/sv(0); for(i = 0; i <= m-1; i++) { if( ap::fp_greater(sv(i),threshold*sv(0)) ) { sutb(i) = utb(i)/sv(i); } else { sutb(i) = 0; } } } else { rep.taskrcond = 0; for(i = 0; i <= m-1; i++) { sutb(i) = 0; } } c.setlength(m); for(i = 0; i <= m-1; i++) { c(i) = 0; } for(i = 0; i <= m-1; i++) { v = sutb(i); ap::vadd(&c(0), 1, &vt(i, 0), 1, ap::vlen(0,m-1), v); } } // // calculate errors // rep.rmserror = 0; rep.avgerror = 0; rep.avgrelerror = 0; rep.maxerror = 0; relcnt = 0; for(i = 0; i <= n-1; i++) { v = ap::vdotproduct(&fmatrix(i, 0), 1, &c(0), 1, ap::vlen(0,m-1)); rep.rmserror = rep.rmserror+ap::sqr(v-y(i)); rep.avgerror = rep.avgerror+fabs(v-y(i)); if( ap::fp_neq(y(i),0) ) { rep.avgrelerror = rep.avgrelerror+fabs(v-y(i))/fabs(y(i)); relcnt = relcnt+1; } rep.maxerror = ap::maxreal(rep.maxerror, fabs(v-y(i))); } rep.rmserror = sqrt(rep.rmserror/n); rep.avgerror = rep.avgerror/n; if( relcnt!=0 ) { rep.avgrelerror = rep.avgrelerror/relcnt; } }