Beispiel #1
0
/*************************************************************************
This function generates  1-dimensional equidistant interpolation task with
moderate Lipshitz constant (close to 1.0)

If N=1 then suborutine generates only one point at the middle of [A,B]

  -- ALGLIB --
     Copyright 02.12.2009 by Bochkanov Sergey
*************************************************************************/
void taskgenint1dequidist(double a,
     double b,
     int n,
     ap::real_1d_array& x,
     ap::real_1d_array& y)
{
    int i;
    double h;

    ap::ap_error::make_assertion(n>=1, "TaskGenInterpolationEqdist1D: N<1!");
    x.setlength(n);
    y.setlength(n);
    if( n>1 )
    {
        x(0) = a;
        y(0) = 2*ap::randomreal()-1;
        h = (b-a)/(n-1);
        for(i = 1; i <= n-1; i++)
        {
            x(i) = a+i*h;
            y(i) = y(i-1)+(2*ap::randomreal()-1)*h;
        }
    }
    else
    {
        x(0) = 0.5*(a+b);
        y(0) = 2*ap::randomreal()-1;
    }
}
Beispiel #2
0
/*************************************************************************
This function generates  1-dimensional Chebyshev-2 interpolation task with
moderate Lipshitz constant (close to 1.0)

If N=1 then suborutine generates only one point at the middle of [A,B]

  -- ALGLIB --
     Copyright 02.12.2009 by Bochkanov Sergey
*************************************************************************/
void taskgenint1dcheb2(double a,
     double b,
     int n,
     ap::real_1d_array& x,
     ap::real_1d_array& y)
{
    int i;

    ap::ap_error::make_assertion(n>=1, "TaskGenInterpolation1DCheb2: N<1!");
    x.setlength(n);
    y.setlength(n);
    if( n>1 )
    {
        for(i = 0; i <= n-1; i++)
        {
            x(i) = 0.5*(b+a)+0.5*(b-a)*cos(ap::pi()*i/(n-1));
            if( i==0 )
            {
                y(i) = 2*ap::randomreal()-1;
            }
            else
            {
                y(i) = y(i-1)+(2*ap::randomreal()-1)*(x(i)-x(i-1));
            }
        }
    }
    else
    {
        x(0) = 0.5*(a+b);
        y(0) = 2*ap::randomreal()-1;
    }
}
Beispiel #3
0
/*************************************************************************
Computation of nodes and weights for a Gauss quadrature formula

The algorithm generates the N-point Gauss quadrature formula  with  weight
function given by coefficients alpha and beta  of  a  recurrence  relation
which generates a system of orthogonal polynomials:

P-1(x)   =  0
P0(x)    =  1
Pn+1(x)  =  (x-alpha(n))*Pn(x)  -  beta(n)*Pn-1(x)

and zeroth moment Mu0

Mu0 = integral(W(x)dx,a,b)

INPUT PARAMETERS:
    Alpha   –   array[0..N-1], alpha coefficients
    Beta    –   array[0..N-1], beta coefficients
                Zero-indexed element is not used and may be arbitrary.
                Beta[I]>0.
    Mu0     –   zeroth moment of the weight function.
    N       –   number of nodes of the quadrature formula, N>=1

OUTPUT PARAMETERS:
    Info    -   error code:
                * -3    internal eigenproblem solver hasn't converged
                * -2    Beta[i]<=0
                * -1    incorrect N was passed
                *  1    OK
    X       -   array[0..N-1] - array of quadrature nodes,
                in ascending order.
    W       -   array[0..N-1] - array of quadrature weights.

  -- ALGLIB --
     Copyright 2005-2009 by Bochkanov Sergey
*************************************************************************/
void gqgeneraterec(const ap::real_1d_array& alpha,
     const ap::real_1d_array& beta,
     double mu0,
     int n,
     int& info,
     ap::real_1d_array& x,
     ap::real_1d_array& w)
{
    int i;
    ap::real_1d_array d;
    ap::real_1d_array e;
    ap::real_2d_array z;

    if( n<1 )
    {
        info = -1;
        return;
    }
    info = 1;
    
    //
    // Initialize
    //
    d.setlength(n);
    e.setlength(n);
    for(i = 1; i <= n-1; i++)
    {
        d(i-1) = alpha(i-1);
        if( ap::fp_less_eq(beta(i),0) )
        {
            info = -2;
            return;
        }
        e(i-1) = sqrt(beta(i));
    }
    d(n-1) = alpha(n-1);
    
    //
    // EVD
    //
    if( !smatrixtdevd(d, e, n, 3, z) )
    {
        info = -3;
        return;
    }
    
    //
    // Generate
    //
    x.setlength(n);
    w.setlength(n);
    for(i = 1; i <= n; i++)
    {
        x(i-1) = d(i-1);
        w(i-1) = mu0*ap::sqr(z(0,i-1));
    }
}
/*************************************************************************
1-dimensional circular real cross-correlation.

For given Pattern/Signal returns corr(Pattern,Signal) (circular).
Algorithm has linearithmic complexity for any M/N.

IMPORTANT:
    for  historical reasons subroutine accepts its parameters in  reversed
    order:   CorrR1DCircular(Signal, Pattern) = Pattern x Signal    (using
    traditional definition of cross-correlation, denoting cross-correlation
    as "x").

INPUT PARAMETERS
    Signal  -   array[0..N-1] - real function to be transformed,
                periodic signal containing pattern
    N       -   problem size
    Pattern -   array[0..M-1] - real function to be transformed,
                non-periodic pattern to search withing signal
    M       -   problem size

OUTPUT PARAMETERS
    R   -   convolution: A*B. array[0..M-1].


  -- ALGLIB --
     Copyright 21.07.2009 by Bochkanov Sergey
*************************************************************************/
void corrr1dcircular(const ap::real_1d_array& signal,
     int m,
     const ap::real_1d_array& pattern,
     int n,
     ap::real_1d_array& c)
{
    ap::real_1d_array p;
    ap::real_1d_array b;
    int i1;
    int i2;
    int i;
    int j2;

    ap::ap_error::make_assertion(n>0&&m>0, "ConvC1DCircular: incorrect N or M!");
    
    //
    // normalize task: make M>=N,
    // so A will be longer (at least - not shorter) that B.
    //
    if( m<n )
    {
        b.setlength(m);
        for(i1 = 0; i1 <= m-1; i1++)
        {
            b(i1) = 0;
        }
        i1 = 0;
        while(i1<n)
        {
            i2 = ap::minint(i1+m-1, n-1);
            j2 = i2-i1;
            ap::vadd(&b(0), &pattern(i1), ap::vlen(0,j2));
            i1 = i1+m;
        }
        corrr1dcircular(signal, m, b, m, c);
        return;
    }
    
    //
    // Task is normalized
    //
    p.setlength(n);
    for(i = 0; i <= n-1; i++)
    {
        p(n-1-i) = pattern(i);
    }
    convr1dcircular(signal, m, p, n, b);
    c.setlength(m);
    ap::vmove(&c(0), &b(n-1), ap::vlen(0,m-n));
    if( m-n+1<=m-1 )
    {
        ap::vmove(&c(m-n+1), &b(0), ap::vlen(m-n+1,m-1));
    }
}
Beispiel #5
0
/*************************************************************************
Nonlinear least squares fitting results.

Called after LSFitNonlinearIteration() returned False.

INPUT PARAMETERS:
    State   -   algorithm state (used by LSFitNonlinearIteration).

OUTPUT PARAMETERS:
    Info    -   completetion code:
                    * -1    incorrect parameters were specified
                    *  1    relative function improvement is no more than
                            EpsF.
                    *  2    relative step is no more than EpsX.
                    *  4    gradient norm is no more than EpsG
                    *  5    MaxIts steps was taken
    C       -   array[0..K-1], solution
    Rep     -   optimization report. Following fields are set:
                * Rep.TerminationType completetion code:
                * 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


  -- ALGLIB --
     Copyright 17.08.2009 by Bochkanov Sergey
*************************************************************************/
void lsfitnonlinearresults(const lsfitstate& state,
     int& info,
     ap::real_1d_array& c,
     lsfitreport& rep)
{

    info = state.repterminationtype;
    if( info>0 )
    {
        c.setlength(state.k);
        ap::vmove(&c(0), 1, &state.c(0), 1, ap::vlen(0,state.k-1));
        rep.rmserror = state.reprmserror;
        rep.avgerror = state.repavgerror;
        rep.avgrelerror = state.repavgrelerror;
        rep.maxerror = state.repmaxerror;
    }
}
/*************************************************************************
Dense solver.

Similar to RMatrixSolveM() but solves task with one right part  (where b/x
are vectors, not matrices).

See RMatrixSolveM()  description  for  more  information  about subroutine
parameters.

  -- ALGLIB --
     Copyright 24.08.2009 by Bochkanov Sergey
*************************************************************************/
void rmatrixsolve(const ap::real_2d_array& a,
     int n,
     const ap::real_1d_array& b,
     int& info,
     densesolverreport& rep,
     ap::real_1d_array& x)
{
    ap::real_2d_array bm;
    ap::real_2d_array xm;

    if( n<=0 )
    {
        info = -1;
        return;
    }
    bm.setlength(n, 1);
    ap::vmove(bm.getcolumn(0, 0, n-1), b.getvector(0, n-1));
    rmatrixsolvem(a, n, bm, 1, info, rep, xm);
    x.setlength(n);
    ap::vmove(x.getvector(0, n-1), xm.getcolumn(0, 0, n-1));
}
/*************************************************************************
1-dimensional real cross-correlation.

For given Pattern/Signal returns corr(Pattern,Signal) (non-circular).

Correlation is calculated using reduction to  convolution.  Algorithm with
max(N,N)*log(max(N,N)) complexity is used (see  ConvC1D()  for  more  info
about performance).

IMPORTANT:
    for  historical reasons subroutine accepts its parameters in  reversed
    order: CorrR1D(Signal, Pattern) = Pattern x Signal (using  traditional
    definition of cross-correlation, denoting cross-correlation as "x").

INPUT PARAMETERS
    Signal  -   array[0..N-1] - real function to be transformed,
                signal containing pattern
    N       -   problem size
    Pattern -   array[0..M-1] - real function to be transformed,
                pattern to search withing signal
    M       -   problem size

OUTPUT PARAMETERS
    R       -   cross-correlation, array[0..N+M-2]:
                * positive lags are stored in R[0..N-1],
                  R[i] = sum(pattern[j]*signal[i+j]
                * negative lags are stored in R[N..N+M-2],
                  R[N+M-1-i] = sum(pattern[j]*signal[-i+j]

NOTE:
    It is assumed that pattern domain is [0..M-1].  If Pattern is non-zero
on [-K..M-1],  you can still use this subroutine, just shift result by K.

  -- ALGLIB --
     Copyright 21.07.2009 by Bochkanov Sergey
*************************************************************************/
void corrr1d(const ap::real_1d_array& signal,
     int n,
     const ap::real_1d_array& pattern,
     int m,
     ap::real_1d_array& r)
{
    ap::real_1d_array p;
    ap::real_1d_array b;
    int i;

    ap::ap_error::make_assertion(n>0&&m>0, "CorrR1D: incorrect N or M!");
    p.setlength(m);
    for(i = 0; i <= m-1; i++)
    {
        p(m-1-i) = pattern(i);
    }
    convr1d(p, m, signal, n, b);
    r.setlength(m+n-1);
    ap::vmove(&r(0), &b(m-1), ap::vlen(0,n-1));
    if( m+n-2>=n )
    {
        ap::vmove(&r(n), &b(0), ap::vlen(n,m+n-2));
    }
}
/*************************************************************************
Dense solver.

This subroutine finds solution of the linear system A*X=B with non-square,
possibly degenerate A.  System  is  solved in the least squares sense, and
general least squares solution  X = X0 + CX*y  which  minimizes |A*X-B| is
returned. If A is non-degenerate, solution in the  usual sense is returned

Additional features include:
* iterative improvement

INPUT PARAMETERS
    A       -   array[0..NRows-1,0..NCols-1], system matrix
    NRows   -   vertical size of A
    NCols   -   horizontal size of A
    B       -   array[0..NCols-1], right part
    Threshold-  a number in [0,1]. Singular values  beyond  Threshold  are
                considered  zero.  Set  it to 0.0, if you don't understand
                what it means, so the solver will choose good value on its
                own.
                
OUTPUT PARAMETERS
    Info    -   return code:
                * -4    SVD subroutine failed
                * -1    if NRows<=0 or NCols<=0 or Threshold<0 was passed
                *  1    if task is solved
    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:
* R2        reciprocal of condition number: 1/cond(A), 2-norm.
* N         = NCols
* K         dim(Null(A))
* CX        array[0..N-1,0..K-1], kernel of A.
            Columns of CX store such vectors that A*CX[i]=0.

  -- ALGLIB --
     Copyright 24.08.2009 by Bochkanov Sergey
*************************************************************************/
void rmatrixsolvels(const ap::real_2d_array& a,
     int nrows,
     int ncols,
     const ap::real_1d_array& b,
     double threshold,
     int& info,
     densesolverlsreport& rep,
     ap::real_1d_array& x)
{
    ap::real_1d_array sv;
    ap::real_2d_array u;
    ap::real_2d_array vt;
    ap::real_1d_array rp;
    ap::real_1d_array utb;
    ap::real_1d_array sutb;
    ap::real_1d_array tmp;
    ap::real_1d_array ta;
    ap::real_1d_array tx;
    ap::real_1d_array buf;
    ap::real_1d_array w;
    int i;
    int j;
    int nsv;
    int kernelidx;
    double v;
    double verr;
    bool svdfailed;
    bool zeroa;
    int rfs;
    int nrfs;
    bool terminatenexttime;
    bool smallerr;

    if( nrows<=0||ncols<=0||ap::fp_less(threshold,0) )
    {
        info = -1;
        return;
    }
    if( ap::fp_eq(threshold,0) )
    {
        threshold = 1000*ap::machineepsilon;
    }
    
    //
    // Factorize A first
    //
    svdfailed = !rmatrixsvd(a, nrows, ncols, 1, 2, 2, sv, u, vt);
    zeroa = ap::fp_eq(sv(0),0);
    if( svdfailed||zeroa )
    {
        if( svdfailed )
        {
            info = -4;
        }
        else
        {
            info = 1;
        }
        x.setlength(ncols);
        for(i = 0; i <= ncols-1; i++)
        {
            x(i) = 0;
        }
        rep.n = ncols;
        rep.k = ncols;
        rep.cx.setlength(ncols, ncols);
        for(i = 0; i <= ncols-1; i++)
        {
            for(j = 0; j <= ncols-1; j++)
            {
                if( i==j )
                {
                    rep.cx(i,j) = 1;
                }
                else
                {
                    rep.cx(i,j) = 0;
                }
            }
        }
        rep.r2 = 0;
        return;
    }
    nsv = ap::minint(ncols, nrows);
    if( nsv==ncols )
    {
        rep.r2 = sv(nsv-1)/sv(0);
    }
    else
    {
        rep.r2 = 0;
    }
    rep.n = ncols;
    info = 1;
    
    //
    // Iterative improvement of xc combined with solution:
    // 1. xc = 0
    // 2. calculate r = bc-A*xc using extra-precise dot product
    // 3. solve A*y = r
    // 4. update x:=x+r
    // 5. goto 2
    //
    // 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
    //
    utb.setlength(nsv);
    sutb.setlength(nsv);
    x.setlength(ncols);
    tmp.setlength(ncols);
    ta.setlength(ncols+1);
    tx.setlength(ncols+1);
    buf.setlength(ncols+1);
    for(i = 0; i <= ncols-1; i++)
    {
        x(i) = 0;
    }
    kernelidx = nsv;
    for(i = 0; i <= nsv-1; i++)
    {
        if( ap::fp_less_eq(sv(i),threshold*sv(0)) )
        {
            kernelidx = i;
            break;
        }
    }
    rep.k = ncols-kernelidx;
    nrfs = densesolverrfsmaxv2(ncols, rep.r2);
    terminatenexttime = false;
    rp.setlength(nrows);
    for(rfs = 0; rfs <= nrfs; rfs++)
    {
        if( terminatenexttime )
        {
            break;
        }
        
        //
        // calculate right part
        //
        if( rfs==0 )
        {
            ap::vmove(&rp(0), &b(0), ap::vlen(0,nrows-1));
        }
        else
        {
            smallerr = true;
            for(i = 0; i <= nrows-1; i++)
            {
                ap::vmove(&ta(0), &a(i, 0), ap::vlen(0,ncols-1));
                ta(ncols) = -1;
                ap::vmove(&tx(0), &x(0), ap::vlen(0,ncols-1));
                tx(ncols) = b(i);
                xdot(ta, tx, ncols+1, buf, v, verr);
                rp(i) = -v;
                smallerr = smallerr&&ap::fp_less(fabs(v),4*verr);
            }
            if( smallerr )
            {
                terminatenexttime = true;
            }
        }
        
        //
        // solve A*dx = rp
        //
        for(i = 0; i <= ncols-1; i++)
        {
            tmp(i) = 0;
        }
        for(i = 0; i <= nsv-1; i++)
        {
            utb(i) = 0;
        }
        for(i = 0; i <= nrows-1; i++)
        {
            v = rp(i);
            ap::vadd(&utb(0), &u(i, 0), ap::vlen(0,nsv-1), v);
        }
        for(i = 0; i <= nsv-1; i++)
        {
            if( i<kernelidx )
            {
                sutb(i) = utb(i)/sv(i);
            }
            else
            {
                sutb(i) = 0;
            }
        }
        for(i = 0; i <= nsv-1; i++)
        {
            v = sutb(i);
            ap::vadd(&tmp(0), &vt(i, 0), ap::vlen(0,ncols-1), v);
        }
        
        //
        // update x:  x:=x+dx
        //
        ap::vadd(&x(0), &tmp(0), ap::vlen(0,ncols-1));
    }
    
    //
    // fill CX
    //
    if( rep.k>0 )
    {
        rep.cx.setlength(ncols, rep.k);
        for(i = 0; i <= rep.k-1; i++)
        {
            ap::vmove(rep.cx.getcolumn(i, 0, ncols-1), vt.getrow(kernelidx+i, 0, ncols-1));
        }
    }
}
Beispiel #9
0
/*************************************************************************
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);
    }
}
Beispiel #10
0
/*************************************************************************
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;
    }
}
Beispiel #11
0
void lsfitscalexy(ap::real_1d_array& x,
     ap::real_1d_array& y,
     int n,
     ap::real_1d_array& xc,
     ap::real_1d_array& yc,
     const ap::integer_1d_array& dc,
     int k,
     double& xa,
     double& xb,
     double& sa,
     double& sb,
     ap::real_1d_array& xoriginal,
     ap::real_1d_array& yoriginal)
{
    double xmin;
    double xmax;
    int i;

    ap::ap_error::make_assertion(n>=1, "LSFitScaleXY: incorrect N");
    ap::ap_error::make_assertion(k>=0, "LSFitScaleXY: incorrect K");
    
    //
    // Calculate xmin/xmax.
    // Force xmin<>xmax.
    //
    xmin = x(0);
    xmax = x(0);
    for(i = 1; i <= n-1; i++)
    {
        xmin = ap::minreal(xmin, x(i));
        xmax = ap::maxreal(xmax, x(i));
    }
    for(i = 0; i <= k-1; i++)
    {
        xmin = ap::minreal(xmin, xc(i));
        xmax = ap::maxreal(xmax, xc(i));
    }
    if( ap::fp_eq(xmin,xmax) )
    {
        if( ap::fp_eq(xmin,0) )
        {
            xmin = -1;
            xmax = +1;
        }
        else
        {
            xmin = 0.5*xmin;
        }
    }
    
    //
    // Transform abscissas: map [XA,XB] to [0,1]
    //
    // Store old X[] in XOriginal[] (it will be used
    // to calculate relative error).
    //
    xoriginal.setlength(n);
    ap::vmove(&xoriginal(0), 1, &x(0), 1, ap::vlen(0,n-1));
    xa = xmin;
    xb = xmax;
    for(i = 0; i <= n-1; i++)
    {
        x(i) = 2*(x(i)-0.5*(xa+xb))/(xb-xa);
    }
    for(i = 0; i <= k-1; i++)
    {
        ap::ap_error::make_assertion(dc(i)>=0, "LSFitScaleXY: internal error!");
        xc(i) = 2*(xc(i)-0.5*(xa+xb))/(xb-xa);
        yc(i) = yc(i)*pow(0.5*(xb-xa), double(dc(i)));
    }
    
    //
    // Transform function values: map [SA,SB] to [0,1]
    // SA = mean(Y),
    // SB = SA+stddev(Y).
    //
    // Store old Y[] in YOriginal[] (it will be used
    // to calculate relative error).
    //
    yoriginal.setlength(n);
    ap::vmove(&yoriginal(0), 1, &y(0), 1, ap::vlen(0,n-1));
    sa = 0;
    for(i = 0; i <= n-1; i++)
    {
        sa = sa+y(i);
    }
    sa = sa/n;
    sb = 0;
    for(i = 0; i <= n-1; i++)
    {
        sb = sb+ap::sqr(y(i)-sa);
    }
    sb = sqrt(sb/n)+sa;
    if( ap::fp_eq(sb,sa) )
    {
        sb = 2*sa;
    }
    if( ap::fp_eq(sb,sa) )
    {
        sb = sa+1;
    }
    for(i = 0; i <= n-1; i++)
    {
        y(i) = (y(i)-sa)/(sb-sa);
    }
    for(i = 0; i <= k-1; i++)
    {
        if( dc(i)==0 )
        {
            yc(i) = (yc(i)-sa)/(sb-sa);
        }
        else
        {
            yc(i) = yc(i)/(sb-sa);
        }
    }
}
Beispiel #12
0
/*************************************************************************
Computation of nodes and weights for a Gauss-Lobatto quadrature formula

The algorithm generates the N-point Gauss-Lobatto quadrature formula  with
weight function given by coefficients alpha and beta of a recurrence which
generates a system of orthogonal polynomials.

P-1(x)   =  0
P0(x)    =  1
Pn+1(x)  =  (x-alpha(n))*Pn(x)  -  beta(n)*Pn-1(x)

and zeroth moment Mu0

Mu0 = integral(W(x)dx,a,b)

INPUT PARAMETERS:
    Alpha   –   array[0..N-2], alpha coefficients
    Beta    –   array[0..N-2], beta coefficients.
                Zero-indexed element is not used, may be arbitrary.
                Beta[I]>0
    Mu0     –   zeroth moment of the weighting function.
    A       –   left boundary of the integration interval.
    B       –   right boundary of the integration interval.
    N       –   number of nodes of the quadrature formula, N>=3
                (including the left and right boundary nodes).

OUTPUT PARAMETERS:
    Info    -   error code:
                * -3    internal eigenproblem solver hasn't converged
                * -2    Beta[i]<=0
                * -1    incorrect N was passed
                *  1    OK
    X       -   array[0..N-1] - array of quadrature nodes,
                in ascending order.
    W       -   array[0..N-1] - array of quadrature weights.

  -- ALGLIB --
     Copyright 2005-2009 by Bochkanov Sergey
*************************************************************************/
void gqgenerategausslobattorec(ap::real_1d_array alpha,
     ap::real_1d_array beta,
     double mu0,
     double a,
     double b,
     int n,
     int& info,
     ap::real_1d_array& x,
     ap::real_1d_array& w)
{
    int i;
    ap::real_1d_array d;
    ap::real_1d_array e;
    ap::real_2d_array z;
    double pim1a;
    double pia;
    double pim1b;
    double pib;
    double t;
    double a11;
    double a12;
    double a21;
    double a22;
    double b1;
    double b2;
    double alph;
    double bet;

    if( n<=2 )
    {
        info = -1;
        return;
    }
    info = 1;
    
    //
    // Initialize, D[1:N+1], E[1:N]
    //
    n = n-2;
    d.setlength(n+2);
    e.setlength(n+1);
    for(i = 1; i <= n+1; i++)
    {
        d(i-1) = alpha(i-1);
    }
    for(i = 1; i <= n; i++)
    {
        if( ap::fp_less_eq(beta(i),0) )
        {
            info = -2;
            return;
        }
        e(i-1) = sqrt(beta(i));
    }
    
    //
    // Caclulate Pn(a), Pn+1(a), Pn(b), Pn+1(b)
    //
    beta(0) = 0;
    pim1a = 0;
    pia = 1;
    pim1b = 0;
    pib = 1;
    for(i = 1; i <= n+1; i++)
    {
        
        //
        // Pi(a)
        //
        t = (a-alpha(i-1))*pia-beta(i-1)*pim1a;
        pim1a = pia;
        pia = t;
        
        //
        // Pi(b)
        //
        t = (b-alpha(i-1))*pib-beta(i-1)*pim1b;
        pim1b = pib;
        pib = t;
    }
    
    //
    // Calculate alpha'(n+1), beta'(n+1)
    //
    a11 = pia;
    a12 = pim1a;
    a21 = pib;
    a22 = pim1b;
    b1 = a*pia;
    b2 = b*pib;
    if( ap::fp_greater(fabs(a11),fabs(a21)) )
    {
        a22 = a22-a12*a21/a11;
        b2 = b2-b1*a21/a11;
        bet = b2/a22;
        alph = (b1-bet*a12)/a11;
    }
    else
    {
        a12 = a12-a22*a11/a21;
        b1 = b1-b2*a11/a21;
        bet = b1/a12;
        alph = (b2-bet*a22)/a21;
    }
    if( ap::fp_less(bet,0) )
    {
        info = -3;
        return;
    }
    d(n+1) = alph;
    e(n) = sqrt(bet);
    
    //
    // EVD
    //
    if( !smatrixtdevd(d, e, n+2, 3, z) )
    {
        info = -3;
        return;
    }
    
    //
    // Generate
    //
    x.setlength(n+2);
    w.setlength(n+2);
    for(i = 1; i <= n+2; i++)
    {
        x(i-1) = d(i-1);
        w(i-1) = mu0*ap::sqr(z(0,i-1));
    }
}