/*************************************************************************
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;
}
}
