Add a useful package (from Source forge) for octave

[CreaPhase.git] / octave_packages / optim-1.2.0 / leasqr.m

%% Copyright (C) 1992-1994 Richard Shrager
%% Copyright (C) 1992-1994 Arthur Jutan <jutan@charon.engga.uwo.ca>
%% Copyright (C) 1992-1994 Ray Muzic <rfm2@ds2.uh.cwru.edu>
%% Copyright (C) 2010, 2011 Olaf Till <i7tiol@t-online.de>
%%
%% This program is free software; you can redistribute it and/or modify it under
%% the terms of the GNU General Public License as published by the Free Software
%% Foundation; either version 3 of the License, or (at your option) any later
%% version.
%%
%% This program is distributed in the hope that it will be useful, but WITHOUT
%% ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
%% FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
%% details.
%%
%% You should have received a copy of the GNU General Public License along with
%% this program; if not, see <http://www.gnu.org/licenses/>.

%%function [f,p,cvg,iter,corp,covp,covr,stdresid,Z,r2]=
%%                   leasqr(x,y,pin,F,{stol,niter,wt,dp,dFdp,options})
%%
%% Levenberg-Marquardt nonlinear regression of f(x,p) to y(x).
%%
%% Version 3.beta
%% Optional parameters are in braces {}.
%% x = vector or matrix of independent variables.
%% y = vector or matrix of observed values.
%% wt = statistical weights (same dimensions as y).  These should be
%%   set to be proportional to (sqrt of var(y))^-1; (That is, the
%%   covariance matrix of the data is assumed to be proportional to
%%   diagonal with diagonal equal to (wt.^2)^-1.  The constant of
%%   proportionality will be estimated.); default = ones( size (y)).
%% pin = vec of initial parameters to be adjusted by leasqr.
%% dp = fractional increment of p for numerical partial derivatives;
%%   default = .001*ones(size(pin))
%%   dp(j) > 0 means central differences on j-th parameter p(j).
%%   dp(j) < 0 means one-sided differences on j-th parameter p(j).
%%   dp(j) = 0 holds p(j) fixed i.e. leasqr wont change initial guess: pin(j)
%% F = name of function in quotes or function handle; the function
%%   shall be of the form y=f(x,p), with y, x, p of the form y, x, pin
%%   as described above.
%% dFdp = name of partial derivative function in quotes or function
%% handle; default is 'dfdp', a slow but general partial derivatives
%% function; the function shall be of the form
%% prt=dfdp(x,f,p,dp,F[,bounds]). For backwards compatibility, the
%% function will only be called with an extra 'bounds' argument if the
%% 'bounds' option is explicitely specified to leasqr (see dfdp.m).
%% stol = scalar tolerance on fractional improvement in scalar sum of
%%   squares = sum((wt.*(y-f))^2); default stol = .0001;
%% niter = scalar maximum number of iterations; default = 20;
%% options = structure, currently recognized fields are 'fract_prec',
%% 'max_fract_change', 'inequc', 'bounds', and 'equc'. For backwards
%% compatibility, 'options' can also be a matrix whose first and
%% second column contains the values of 'fract_prec' and
%% 'max_fract_change', respectively.
%%   Field 'options.fract_prec': column vector (same length as 'pin')
%%   of desired fractional precisions in parameter estimates.
%%   Iterations are terminated if change in parameter vector (chg)
%%   relative to current parameter estimate is less than their
%%   corresponding elements in 'options.fract_prec' [ie. all (abs
%%   (chg) < abs (options.fract_prec .* current_parm_est))] on two
%%   consecutive iterations, default = zeros().
%%   Field 'options.max_fract_change': column vector (same length as
%%   'pin) of maximum fractional step changes in parameter vector.
%%   Fractional change in elements of parameter vector is constrained to
%%   be at most 'options.max_fract_change' between sucessive iterations.
%%   [ie. abs(chg(i))=abs(min([chg(i)
%%   options.max_fract_change(i)*current param estimate])).], default =
%%   Inf*ones().
%%   Field 'options.inequc': cell-array containing up to four entries,
%%   two entries for linear inequality constraints and/or one or two
%%   entries for general inequality constraints. Initial parameters
%%   must satisfy these constraints. Either linear or general
%%   constraints may be the first entries, but the two entries for
%%   linear constraints must be adjacent and, if two entries are given
%%   for general constraints, they also must be adjacent. The two
%%   entries for linear constraints are a matrix (say m) and a vector
%%   (say v), specifying linear inequality constraints of the form
%%   `m.' * parameters + v >= 0'. If the constraints are just bounds,
%%   it is suggested to specify them in 'options.bounds' instead,
%%   since then some sanity tests are performed, and since the
%%   function 'dfdp.m' is guarantied not to violate constraints during
%%   determination of the numeric gradient only for those constraints
%%   specified as 'bounds' (possibly with violations due to a certain
%%   inaccuracy, however, except if no constraints except bounds are
%%   specified). The first entry for general constraints must be a
%%   differentiable vector valued function (say h), specifying general
%%   inequality constraints of the form `h (p[, idx]) >= 0'; p is the
%%   column vector of optimized paraters and the optional argument idx
%%   is a logical index. h has to return the values of all constraints
%%   if idx is not given, and has to return only the indexed
%%   constraints if idx is given (so computation of the other
%%   constraints can be spared). If a second entry for general
%%   constraints is given, it must be a function (say dh) which
%%   returnes a matrix whos rows contain the gradients of the
%%   constraint function h with respect to the optimized parameters.
%%   It has the form jac_h = dh (vh, p, dp, h, idx[, bounds]); p is
%%   the column vector of optimized parameters, and idx is a logical
%%   index --- only the rows indexed by idx must be returned (so
%%   computation of the others can be spared). The other arguments of
%%   dh are for the case that dh computes numerical gradients: vh is
%%   the column vector of the current values of the constraint
%%   function h, with idx already applied. h is a function h (p) to
%%   compute the values of the constraints for parameters p, it will
%%   return only the values indexed by idx. dp is a suggestion for
%%   relative step width, having the same value as the argument 'dp'
%%   of leasqr above. If bounds were specified to leasqr, they are
%%   provided in the argument bounds of dh, to enable their
%%   consideration in determination of numerical gradients. If dh is
%%   not specified to leasqr, numerical gradients are computed in the
%%   same way as with 'dfdp.m' (see above). If some constraints are
%%   linear, they should be specified as linear constraints (or
%%   bounds, if applicable) for reasons of performance, even if
%%   general constraints are also specified.
%%   Field 'options.bounds': two-column-matrix, one row for each
%%   parameter in 'pin'. Each row contains a minimal and maximal value
%%   for each parameter. Default: [-Inf, Inf] in each row. If this
%%   field is used with an existing user-side function for 'dFdp'
%%   (see above) the functions interface might have to be changed.
%%   Field 'options.equc': equality constraints, specified the same
%%   way as inequality constraints (see field 'options.inequc').
%%   Initial parameters must satisfy these constraints.
%%   Note that there is possibly a certain inaccuracy in honoring
%%   constraints, except if only bounds are specified. 
%%   _Warning_: If constraints (or bounds) are set, returned guesses
%%   of corp, covp, and Z are generally invalid, even if no constraints
%%   are active for the final parameters. If equality constraints are
%%   specified, corp, covp, and Z are not guessed at all.
%%   Field 'options.cpiv': Function for complementary pivot algorithm
%%   for inequality constraints, default: cpiv_bard. No different
%%   function is supplied.
%%
%%          OUTPUT VARIABLES
%% f = column vector of values computed: f = F(x,p).
%% p = column vector trial or final parameters. i.e, the solution.
%% cvg = scalar: = 1 if convergence, = 0 otherwise.
%% iter = scalar number of iterations used.
%% corp = correlation matrix for parameters.
%% covp = covariance matrix of the parameters.
%% covr = diag(covariance matrix of the residuals).
%% stdresid = standardized residuals.
%% Z = matrix that defines confidence region (see comments in the source).
%% r2 = coefficient of multiple determination, intercept form.
%%
%% Not suitable for non-real residuals.
%%
%% References:
%% Bard, Nonlinear Parameter Estimation, Academic Press, 1974.
%% Draper and Smith, Applied Regression Analysis, John Wiley and Sons, 1981.

function [f,p,cvg,iter,corp,covp,covr,stdresid,Z,r2]= ...
      leasqr(x,y,pin,F,stol,niter,wt,dp,dFdp,options)

  %% The following two blocks of comments are chiefly from the original
  %% version for Matlab. For later changes the logs of the Octave Forge
  %% svn repository should also be consulted.

  %% A modified version of Levenberg-Marquardt
  %% Non-Linear Regression program previously submitted by R.Schrager.
  %% This version corrects an error in that version and also provides
  %% an easier to use version with automatic numerical calculation of
  %% the Jacobian Matrix. In addition, this version calculates statistics
  %% such as correlation, etc....
  %%
  %% Version 3 Notes
  %% Errors in the original version submitted by Shrager (now called
  %% version 1) and the improved version of Jutan (now called version 2)
  %% have been corrected.
  %% Additional features, statistical tests, and documentation have also been
  %% included along with an example of usage.  BEWARE: Some the the input and
  %% output arguments were changed from the previous version.
  %%
  %%     Ray Muzic     <rfm2@ds2.uh.cwru.edu>
  %%     Arthur Jutan  <jutan@charon.engga.uwo.ca>

  %% Richard I. Shrager (301)-496-1122
  %% Modified by A.Jutan (519)-679-2111
  %% Modified by Ray Muzic 14-Jul-1992
  %%       1) add maxstep feature for limiting changes in parameter estimates
  %%          at each step.
  %%       2) remove forced columnization of x (x=x(:)) at beginning. x
  %%          could be a matrix with the ith row of containing values of
  %%          the independent variables at the ith observation.
  %%       3) add verbose option
  %%       4) add optional return arguments covp, stdresid, chi2
  %%       5) revise estimates of corp, stdev
  %% Modified by Ray Muzic 11-Oct-1992
  %%    1) revise estimate of Vy.  remove chi2, add Z as return values
  %%       (later remark: the current code contains no variable Vy)
  %% Modified by Ray Muzic 7-Jan-1994
  %%       1) Replace ones(x) with a construct that is compatible with versions
  %%          newer and older than v 4.1.
  %%       2) Added global declaration of verbose (needed for newer than v4.x)
  %%       3) Replace return value var, the variance of the residuals
  %%          with covr, the covariance matrix of the residuals.
  %%       4) Introduce options as 10th input argument.  Include
  %%          convergence criteria and maxstep in it.
  %%       5) Correct calculation of xtx which affects coveraince estimate.
  %%       6) Eliminate stdev (estimate of standard deviation of
  %%          parameter estimates) from the return values.  The covp is a
  %%          much more meaningful expression of precision because it
  %%          specifies a confidence region in contrast to a confidence
  %%          interval.. If needed, however, stdev may be calculated as
  %%          stdev=sqrt(diag(covp)).
  %%       7) Change the order of the return values to a more logical order.
  %%       8) Change to more efficent algorithm of Bard for selecting epsL.
  %%       9) Tighten up memory usage by making use of sparse matrices (if 
  %%          MATLAB version >= 4.0) in computation of covp, corp, stdresid.
  %% Modified by Francesco Potortì
  %%       for use in Octave
  %% Added linear inequality constraints with quadratic programming to
  %% this file and special case bounds to this file and to dfdp.m
  %% (24-Feb-2010) and later also general inequality constraints
  %% (12-Apr-2010) (Reference: Bard, Y., 'An eclectic approach to
  %% nonlinear programming', Proc. ANU Sem. Optimization, Canberra,
  %% Austral. Nat. Univ.). Differences from the reference: adaption to
  %% svd-based algorithm, linesearch or stepwidth adaptions to ensure
  %% decrease in objective function omitted to rather start a new
  %% overall cycle with a new epsL, some performance gains from linear
  %% constraints even if general constraints are specified. Equality
  %% constraints also implemented. Olaf Till
  %% Now split into files leasqr.m and __lm_svd__.m.

  %% needed for some anonymous functions
  if (exist ('ifelse') ~= 5)
    ifelse = @ scalar_ifelse;
  end

  __plot_cmds__ (); % flag persistent variables invalid

  global verbose;

  %% argument processing
  %%

  if (nargin > 8)
    if (ischar (dFdp))
      dfdp = str2func (dFdp);
    else
      dfdp = dFdp;
    end
  end
  
  if (nargin <= 7) dp=.001*(pin*0+1); end %DT
  if (nargin <= 6) wt = ones (size (y)); end    % SMB modification
  if (nargin <= 5) niter = []; end
  if (nargin == 4) stol=.0001; end
  if (ischar (F)) F = str2func (F); end
  %%

  if (any (size (y) ~= size (wt)))
    error ('dimensions of observations and weights do not match');
  end
  wtl = wt(:);
  pin=pin(:); dp=dp(:); %change all vectors to columns
  [rows_y, cols_y] = size (y);
  m = rows_y * cols_y; n=length(pin);
  f_pin = F (x, pin);
  if (any (size (f_pin) ~= size (y)))
    error ('dimensions of returned values of model function and of observations do not match');
  end
  f_pin = y - f_pin;

  dFdp = @ (p, dfdp_hook) - dfdp (x, y(:) - dfdp_hook.f, p, dp, F);

  %% processing of 'options'
  pprec = zeros (n, 1);
  maxstep = Inf * ones (n, 1);
  have_gencstr = false; % no general constraints
  have_genecstr = false; % no general equality constraints
  n_gencstr = 0;
  mc = zeros (n, 0);
  vc = zeros (0, 1); rv = 0;
  emc = zeros (n, 0);
  evc = zeros (0, 1); erv = 0;
  bounds = cat (2, -Inf * ones (n, 1), Inf * ones (n, 1));
  pin_cstr.inequ.lin_except_bounds = [];;
  pin_cstr.inequ.gen = [];;
  pin_cstr.equ.lin = [];;
  pin_cstr.equ.gen = [];;
  dfdp_bounds = {};
  cpiv = @ cpiv_bard;
  eq_idx = []; % numerical index for equality constraints in all
                                % constraints, later converted to
                                % logical index
  if (nargin > 9)
    if (ismatrix (options)) % backwards compatibility
      tp = options;
      options = struct ('fract_prec', tp(:, 1));
      if (columns (tp) > 1)
        options.max_fract_change = tp(:, 2);
      end
    end
    if (isfield (options, 'cpiv') && ~isempty (options.cpiv))
      %% As yet there is only one cpiv function distributed with leasqr,
      %% but this may change; the algorithm of cpiv_bard is said to be
      %% relatively fast, but may have disadvantages.
      if (ischar (options.cpiv))
        cpiv = str2func (options.cpiv);
      else
        cpiv = options.cpiv;
      end
    end
    if (isfield (options, 'fract_prec'))
      pprec = options.fract_prec;
      if (any (size (pprec) ~= [n, 1]))
        error ('fractional precisions: wrong dimensions');
      end
    end
    if (isfield (options, 'max_fract_change'))
      maxstep = options.max_fract_change;
      if (any (size (maxstep) ~= [n, 1]))
        error ('maximum fractional step changes: wrong dimensions');
      end
    end
    if (isfield (options, 'inequc'))
      inequc = options.inequc;
      if (ismatrix (inequc{1}))
        mc = inequc{1};
        vc = inequc{2};
        if (length (inequc) > 2)
          have_gencstr = true;
          f_gencstr = inequc{3};
          if (length (inequc) > 3)
            df_gencstr = inequc{4};
          else
            df_gencstr = @ dcdp;
          end
        end
      else
        lid = 0; % no linear constraints
        have_gencstr = true;
        f_gencstr = inequc{1};
        if (length (inequc) > 1)
          if (ismatrix (inequc{2}))
            lid = 2;
            df_gencstr = @ dcdp;
          else
            df_gencstr = inequc{2};
            if (length (inequc) > 2)
              lid = 3;
            end
          end
        else
          df_gencstr = @ dcdp;
        end
        if (lid)
          mc = inequc{lid};
          vc = inequc{lid + 1};
        end
      end
      if (have_gencstr)
        if (ischar (f_gencstr))
          f_gencstr = str2func (f_gencstr);
        end
        tp = f_gencstr (pin);
        n_gencstr = length (tp);
        f_gencstr = @ (p, idx) tf_gencstr (p, idx, f_gencstr);
        if (ischar (df_gencstr))
          df_gencstr = str2func (df_gencstr);
        end
        if (strcmp (func2str (df_gencstr), 'dcdp'))
          df_gencstr = @ (f, p, dp, idx, db) ...
              df_gencstr (f(idx), p, dp, ...
                          @ (tp) f_gencstr (tp, idx), db{:});
        else
          df_gencstr = @ (f, p, dp, idx, db) ...
              df_gencstr (f(idx), p, dp, ...
                          @ (tp) f_gencstr (tp, idx), idx, db{:});
        end
      end
      [rm, cm] = size (mc);
      [rv, cv] = size (vc);
      if (rm ~= n || cm ~= rv || cv ~= 1)
        error ('linear inequality constraints: wrong dimensions');
      end
      pin_cstr.inequ.lin_except_bounds = mc.' * pin + vc;
      if (have_gencstr)
        pin_cstr.inequ.gen = tp;
      end
    end
    if (isfield (options, 'equc'))
      equc = options.equc;
      if (ismatrix (equc{1}))
        emc = equc{1};
        evc = equc{2};
        if (length (equc) > 2)
          have_genecstr = true;
          f_genecstr = equc{3};
          if (length (equc) > 3)
            df_genecstr = equc{4};
          else
            df_genecstr = @ dcdp;
          end
        end
      else
        lid = 0; % no linear constraints
        have_genecstr = true;
        f_genecstr = equc{1};
        if (length (equc) > 1)
          if (ismatrix (equc{2}))
            lid = 2;
            df_genecstr = @ dcdp;
          else
            df_genecstr = equc{2};
            if (length (equc) > 2)
              lid = 3;
            end
          end
        else
          df_genecstr = @ dcdp;
        end
        if (lid)
          emc = equc{lid};
          evc = equc{lid + 1};
        end
      end
      if (have_genecstr)
        if (ischar (f_genecstr))
          f_genecstr = str2func (f_genecstr);
        end
        tp = f_genecstr (pin);
        n_genecstr = length (tp);
        f_genecstr = @ (p, idx) tf_gencstr (p, idx, f_genecstr);
        if (ischar (df_genecstr))
          df_genecstr = str2func (df_genecstr);
        end
        if (strcmp (func2str (df_genecstr), 'dcdp'))
          df_genecstr = @ (f, p, dp, idx, db) ...
              df_genecstr (f, p, dp, ...
                           @ (tp) f_genecstr (tp, idx), db{:});
        else
          df_genecstr = @ (f, p, dp, idx, db) ...
              df_genecstr (f, p, dp, ...
                           @ (tp) f_genecstr (tp, idx), idx, db{:});
        end
      end
      [erm, ecm] = size (emc);
      [erv, ecv] = size (evc);
      if (erm ~= n || ecm ~= erv || ecv ~= 1)
        error ('linear equality constraints: wrong dimensions');
      end
      pin_cstr.equ.lin = emc.' * pin + evc;
      if (have_genecstr)
        pin_cstr.equ.gen = tp;
      end
    end
    if (isfield (options, 'bounds'))
      bounds = options.bounds;
      if (any (size (bounds) ~= [n, 2]))
        error ('bounds: wrong dimensions');
      end
      idx = bounds(:, 1) > bounds(:, 2);
      tp = bounds(idx, 2);
      bounds(idx, 2) = bounds(idx, 1);
      bounds(idx, 1) = tp;
      %% It is possible to take this decision here, since this frontend
      %% is used only with one certain backend. The backend will check
      %% this again; but it will not reference 'dp' in its message,
      %% thats why the additional check here.
      idx = bounds(:, 1) == bounds(:, 2);
      if (any (idx))
        warning ('leasqr:constraints', 'lower and upper bounds identical for some parameters, setting the respective elements of dp to zero');
        dp(idx) = 0;
      end
      %%
      tp = eye (n);
      lidx = ~isinf (bounds(:, 1));
      uidx = ~isinf (bounds(:, 2));
      mc = cat (2, mc, tp(:, lidx), - tp(:, uidx));
      vc = cat (1, vc, - bounds(lidx, 1), bounds(uidx, 2));
      [rm, cm] = size (mc);
      [rv, cv] = size (vc);
      dfdp_bounds = {bounds};
      dFdp = @ (p, dfdp_hook) - dfdp (x, y(:) - dfdp_hook.f, p, dp, ...
                                      F, bounds);
    end
    %% concatenate inequality and equality constraint functions, mc, and
    %% vc; update eq_idx, rv, n_gencstr, have_gencstr
    if (erv > 0)
      mc = cat (2, mc, emc);
      vc = cat (1, vc, evc);
      eq_idx = rv + 1 : rv + erv;
      rv = rv + erv;
    end
    if (have_genecstr)
      eq_idx = cat (2, eq_idx, ...
                    rv + n_gencstr + 1 : rv + n_gencstr + n_genecstr);
      nidxi = 1 : n_gencstr;
      nidxe = n_gencstr + 1 : n_gencstr + n_genecstr;
      n_gencstr = n_gencstr + n_genecstr;
      if (have_gencstr)
        f_gencstr = @ (p, idx) cat (1, ...
                                    f_gencstr (p, idx(nidxi)), ...
                                    f_genecstr (p, idx(nidxe)));
        df_gencstr = @ (f, p, dp, idx, db) ...
            cat (1, ...
                 df_gencstr (f(nidxi), p, dp, idx(nidxi), db), ...
                 df_genecstr (f(nidxe), p, dp, idx(nidxe), db));
      else
        f_gencstr = f_genecstr;
        df_gencstr = df_genecstr;
        have_gencstr = true;
      end
    end
  end
  if (have_gencstr)
    nidxl = 1:rv;
    nidxh = rv+1:rv+n_gencstr;
    f_cstr = @ (p, idx) ...
        cat (1, mc(:, idx(nidxl)).' * p + vc(idx(nidxl), 1), ...
             f_gencstr (p, idx(nidxh)));
    %% in the case of this interface, diffp is already zero at fixed;
    %% also in this special case, dfdp_bounds can be filled in directly
    %% --- otherwise it would be a field of hook in the called function
    df_cstr = @ (p, idx, dfdp_hook) ...
        cat (1, mc(:, idx(nidxl)).', ...
             df_gencstr (dfdp_hook.f(nidxh), p, dp, ...
                         idx(nidxh), ...
                         dfdp_bounds));
  else
    f_cstr = @ (p, idx) mc(:, idx).' * p + vc(idx, 1);
    df_cstr = @ (p, idx, dfdp_hook) mc(:, idx).';
  end



  %% in a general interface, check for all(fixed) here

  %% passed constraints
  hook.mc = mc; % matrix of linear constraints
  hook.vc = vc; % vector of linear constraints
  hook.f_cstr = f_cstr; % function of all constraints
  hook.df_cstr = df_cstr; % function of derivatives of all constraints
  hook.n_gencstr = n_gencstr; % number of non-linear constraints
  hook.eq_idx = false (size (vc, 1) + n_gencstr, 1);
  hook.eq_idx(eq_idx) = true; % logical index of equality constraints in
                                % all constraints
  hook.lbound = bounds(:, 1); % bounds, subset of linear inequality
                                % constraints in mc and vc
  hook.ubound = bounds(:, 2);

  %% passed values of constraints for initial parameters
  hook.pin_cstr = pin_cstr;

  %% passed derivative of model function
  hook.dfdp = dFdp;

  %% passed function for complementary pivoting
  hook.cpiv = cpiv;

  %% passed value of residual function for initial parameters
  hook.f_pin = f_pin;

  %% passed options
  hook.max_fract_change = maxstep;
  hook.fract_prec = pprec;
  hook.TolFun = stol;
  hook.MaxIter = niter;
  hook.weights = wt;
  hook.fixed = dp == 0;
  if (verbose)
    hook.Display = 'iter';
    __plot_cmds__ = @ __plot_cmds__; # for bug #31484 (Octave <= 3.2.4)
    hook.plot_cmd = @ (f) __plot_cmds__ (x, y, y - f);
  else
    hook.Display = 'off';
  end

  %% only preliminary, for testing
  hook.testing = false;
  hook.new_s = false;
  if (exist ('options'))
    if (isfield (options, 'testing'))
      hook.testing = options.testing;
    end
    if (isfield (options, 'new_s'))
      hook.new_s = options.new_s;
    end
  end

  [p, resid, cvg, outp] = __lm_svd__ (@ (p) y - F (x, p), pin, hook);
  f = y - resid;
  iter = outp.niter;
  cvg = cvg > 0;

  if (~cvg) disp(' CONVERGENCE NOT ACHIEVED! '); end

  if (~(verbose || nargout > 4)) return; end

  yl = y(:);
  f = f(:);
  %% CALC VARIANCE COV MATRIX AND CORRELATION MATRIX OF PARAMETERS
  %% re-evaluate the Jacobian at optimal values
  jac = dFdp (p, struct ('f', f));
  msk = ~hook.fixed;
  n = sum(msk);           % reduce n to equal number of estimated parameters
  jac = jac(:, msk);    % use only fitted parameters

  %% following section is Ray Muzic's estimate for covariance and correlation
  %% assuming covariance of data is a diagonal matrix proportional to
  %% diag(1/wt.^2).  
  %% cov matrix of data est. from Bard Eq. 7-5-13, and Row 1 Table 5.1 

  tp = wtl.^2;
  if (exist('sparse'))  % save memory
    Q = sparse (1:m, 1:m, 1 ./ tp);
    Qinv = sparse (1:m, 1:m, tp);
  else
    Q = diag (ones (m, 1) ./ tp);
    Qinv = diag (tp);
  end
  resid = resid(:); % un-weighted residuals
  if (~isreal (resid)) error ('residuals are not real'); end
  tp = resid.' * Qinv * resid;
  covr = (tp / m) * Q;    %covariance of residuals

  %% Matlab compatibility and avoiding recomputation make the following
  %% logic clumsy.
  compute = 1;
  if (m <= n || any (eq_idx))
    compute = 0;
  else
    Qinv = ((m - n) / tp) * Qinv;
    %% simplified Eq. 7-5-13, Bard; cov of parm est, inverse; outer
    %% parantheses contain inverse of guessed covariance matrix of data
    covpinv = jac.' * Qinv * jac;
    if (exist ('rcond') && rcond (covpinv) <= eps)
      compute = 0;
    elseif (rank (covpinv) < n)
      %% above test is not equivalent to 'rcond' and may unnecessarily
      %% reject some matrices
      compute = 0;
    end
  end
  if (compute)
    covp = inv (covpinv);
    d=sqrt(diag(covp));
    corp = covp ./ (d * d.');
  else
    covp = NA * ones (n);
    corp = covp;
  end

  if (exist('sparse'))
    covr=spdiags(covr,0);
  else
    covr=diag(covr);                 % convert returned values to
                                % compact storage
  end
  covr = reshape (covr, rows_y, cols_y);
  stdresid = resid .* abs (wtl) / sqrt (tp / m); % equivalent to resid ./
                                % sqrt (covr)
  stdresid = reshape (stdresid, rows_y, cols_y);

  if (~(verbose || nargout > 8)) return; end

  if (m > n && ~any (eq_idx))
    Z = ((m - n) / (n * resid.' * Qinv * resid)) * covpinv;
  else
    Z = NA * ones (n);
  end

%%% alt. est. of cov. mat. of parm.:(Delforge, Circulation, 82:1494-1504, 1990
  %%disp('Alternate estimate of cov. of param. est.')
  %%acovp=resid'*Qinv*resid/(m-n)*inv(jac'*Qinv*jac);

  if (~(verbose || nargout > 9)) return; end

  %%Calculate R^2, intercept form
  %%
  tp = sumsq (yl - mean (yl));
  if (tp > 0)
    r2 = 1 - sumsq (resid) / tp;
  else
    r2 = NA;
  end

  %% if someone has asked for it, let them have it
  %%
  if (verbose)
    __plot_cmds__ (x, y, f);
    disp(' Least Squares Estimates of Parameters')
    disp(p.')
    disp(' Correlation matrix of parameters estimated')
    disp(corp)
    disp(' Covariance matrix of Residuals' )
    disp(covr)
    disp(' Correlation Coefficient R^2')
    disp(r2)
    fprintf(' 95%% conf region: F(0.05)(%.0f,%.0f)>= delta_pvec.%s*Z*delta_pvec\n', n, m - n, char (39)); % works with ' and '
    Z
    %% runs test according to Bard. p 201.
    n1 = sum (resid > 0);
    n2 = sum (resid < 0);
    nrun=sum(abs(diff(resid > 0)))+1;
    if ((n1 > 10) && (n2 > 10)) % sufficent data for test?
      zed=(nrun-(2*n1*n2/(n1+n2)+1)+0.5)/(2*n1*n2*(2*n1*n2-n1-n2)...
        /((n1+n2)^2*(n1+n2-1)));
      if (zed < 0)
        prob = erfc(-zed/sqrt(2))/2*100;
        disp([num2str(prob),'% chance of fewer than ',num2str(nrun),' runs.']);
      else
        prob = erfc(zed/sqrt(2))/2*100;
        disp([num2str(prob),'% chance of greater than ',num2str(nrun),' runs.']);
      end
    end
  end

function ret = tf_gencstr (p, idx, f)

  %% necessary since user function f_gencstr might return [] or a row
  %% vector

  ret = f (p, idx);
  if (isempty (ret))
    ret = zeros (0, 1);
  elseif (size (ret, 2) > 1)
    ret = ret(:);
  end

function fval = scalar_ifelse (cond, tval, fval)

  %% needed for some anonymous functions, builtin ifelse only available
  %% in Octave > 3.2; we need only the scalar case here

  if (cond)
    fval = tval;
  end

%!demo
%! % Define functions
%! leasqrfunc = @(x, p) p(1) * exp (-p(2) * x);
%! leasqrdfdp = @(x, f, p, dp, func) [exp(-p(2)*x), -p(1)*x.*exp(-p(2)*x)];
%!
%! % generate test data
%! t = [1:10:100]';
%! p = [1; 0.1];
%! data = leasqrfunc (t, p);
%! 
%! rnd = [0.352509; -0.040607; -1.867061; -1.561283; 1.473191; ...
%!        0.580767;  0.841805;  1.632203; -0.179254; 0.345208];
%!
%! % add noise
%! % wt1 = 1 /sqrt of variances of data
%! % 1 / wt1 = sqrt of var = standard deviation
%! wt1 = (1 + 0 * t) ./ sqrt (data); 
%! data = data + 0.05 * rnd ./ wt1; 
%!
%! % Note by Thomas Walter <walter@pctc.chemie.uni-erlangen.de>:
%! %
%! % Using a step size of 1 to calculate the derivative is WRONG !!!!
%! % See numerical mathbooks why.
%! % A derivative calculated from central differences need: s 
%! %     step = 0.001...1.0e-8
%! % And onesided derivative needs:
%! %     step = 1.0e-5...1.0e-8 and may be still wrong
%!
%! F = leasqrfunc;
%! dFdp = leasqrdfdp; % exact derivative
%! % dFdp = dfdp;     % estimated derivative
%! dp = [0.001; 0.001];
%! pin = [.8; .05]; 
%! stol=0.001; niter=50;
%! minstep = [0.01; 0.01];
%! maxstep = [0.8; 0.8];
%! options = [minstep, maxstep];
%!
%! global verbose;
%! verbose = 1;
%! [f1, p1, kvg1, iter1, corp1, covp1, covr1, stdresid1, Z1, r21] = ...
%!    leasqr (t, data, pin, F, stol, niter, wt1, dp, dFdp, options);

%!demo
%!  %% Example for linear inequality constraints.
%!  %% model function:
%!  F = @ (x, p) p(1) * exp (p(2) * x);
%!  %% independents and dependents:
%!  x = 1:5;
%!  y = [1, 2, 4, 7, 14];
%!  %% initial values:
%!  init = [.25; .25];
%!  %% other configuration (default values):
%!  tolerance = .0001;
%!  max_iterations = 20;
%!  weights = ones (1, 5);
%!  dp = [.001; .001]; % bidirectional numeric gradient stepsize
%!  dFdp = 'dfdp'; % function for gradient (numerical)
%!
%!  %% linear constraints, A.' * parametervector + B >= 0
%!  A = [1; -1]; B = 0; % p(1) >= p(2);
%!  options.inequc = {A, B};
%!
%!  %% start leasqr, be sure that 'verbose' is not set
%!  global verbose; verbose = false;
%!  [f, p, cvg, iter] = ...
%!      leasqr (x, y, init, F, tolerance, max_iterations, ...
%!            weights, dp, dFdp, options)