File Coverage

blib/lib/PDL/Fit/Levmar.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             #
2             # GENERATED WITH PDL::PP from levmar.pd! Don't modify!
3             #
4             package PDL::Fit::Levmar;
5              
6             our @EXPORT_OK = qw(levmar levmar_report levmar_chkjac levmar_der_ levmar_der_lb_ub levmar_der_ub levmar_der_lb levmar_diff_ levmar_diff_lb_ub levmar_diff_ub levmar_diff_lb _levmar_chkjac _levmar_chkjac_no_t );
7             our %EXPORT_TAGS = (Func=>\@EXPORT_OK);
8              
9 7     7   1547075 use PDL::Core;
  7         16  
  7         52  
10 7     7   2504 use PDL::Exporter;
  7         14  
  7         44  
11 7     7   244 use DynaLoader;
  7         21  
  7         5694  
12              
13              
14             our $VERSION = '0.0108';
15             our @ISA = ( 'PDL::Exporter','DynaLoader' );
16             push @PDL::Core::PP, __PACKAGE__;
17             bootstrap PDL::Fit::Levmar $VERSION;
18              
19              
20              
21              
22              
23              
24              
25              
26             #line 14 "levmar.pd"
27              
28             #use Data::Dumper;
29              
30             =head1 NAME
31              
32             PDL::Fit::Levmar - Levenberg-Marquardt fit/optimization routines
33              
34             =head1 DESCRIPTION
35              
36             Levenberg-Marquardt routines for least-squares fit to
37             functions non-linear in fit parameters.
38              
39             This module provides a L ( L ) interface to the non-linear fitting
40             library levmar 2.5 (written in C). Levmar is
41             L aware (in the L sense), provides support for analytic
42             or finite difference derivatives (in case no analytic
43             derivatives are supplied), L and/or L
44             and/or L
45             constraints (with L as a special
46             case) and pure single or double precision computation. The
47             routines are re-entrant, so they can be used in
48             multi-threaded applications (not tested!). Levmar is suited
49             both for data fitting and for optimization problems.
50              
51             The source code for the C levmar library is included in this
52             distribution. However, linearly-constrained fitting requires
53             that C be built with support for B
54             and B libraries. See the files F and
55             F, for more information. If
56             C is built without support for C,
57             the fitting options C, C, C, C, and C may
58             not be used. All other options, including C, do not
59             require C.
60              
61             User supplied fit functions can be written in perl code that
62             takes pdls as arguments, or, for efficiency, in in a simple
63             function description language (C), which is rapidly and
64             transparently translated to C, compiled, and dynamically
65             linked. Fit functions may also be written in pure C. If C
66             or C fit functions are used, the entire fitting
67             procedure is done in pure compiled C. The compilation and
68             linking is done only the first time the function is defined.
69              
70             There is a document distributed with this module
71             F<./doc/levmar.pdf> by the author of liblevmar describing
72             the fit algorithms. Additional information on liblevmar is available at
73             L
74              
75             Don't confuse this module with, but see also, L.
76              
77             =head1 SYNOPSIS
78              
79             use PDL::Fit::Levmar;
80             $result_hash = levmar($params,$x,$t, FUNC => '
81             function somename
82             x = p0 * exp(-t*t * p1);');
83             print levmar_report($result_hash);
84              
85             =head1 EXAMPLES
86              
87             A number of examples of invocations of C follow. The test
88             directory C<./t> in the module distribution contains many more examples.
89             The following seven examples are included as stand-alone scripts in the
90             ./examples/ directory. Some of the necessary lines are not repeated in
91             each example below.
92              
93             =over 3
94              
95             =item example--1
96              
97             In this example we fill co-ordinate $t and ordinate $x arrays
98             with 100 pairs of sample data. Then we call the fit routine
99             with initial guesses of the parameters.
100              
101             use PDL::LiteF;
102             use PDL::Fit::Levmar;
103             use PDL::NiceSlice;
104            
105             $n = 100;
106             $t = 10 * (sequence($n)/$n -1/2);
107             $x = 3 * exp(-$t*$t * .3 );
108             $p = pdl [ 1, 1 ]; # initial parameter guesses
109              
110             $h = levmar($p,$x,$t, FUNC =>
111             ' function
112             x = p0 * exp( -t*t * p1);
113             ');
114             print levmar_report($h);
115              
116             This example gives the output:
117              
118             Estimated parameters: [ 3 0.3]
119             Covariance:
120             [
121             [5.3772081e-25 7.1703376e-26]
122             [7.1703376e-26 2.8682471e-26]
123             ]
124              
125             ||e||_2 at initial parameters = 125.201
126             Errors at estimated parameters:
127             ||e||_2 = 8.03854e-22
128             ||J^T e||_inf = 2.69892e-05
129             ||Dp||_2 = 3.9274e-15
130             \mu/max[J^T J]_ii ] = 1.37223e-05
131             number of iterations = 15
132             reason for termination: = stopped by small ||e||_2
133             number of function evaluations = 20
134             number of jacobian evaluations = 2
135              
136             In the example above and all following examples, it is necessary
137             to include the three C statements at the top of the file.
138             The fit function in this example is in C code.
139             The parameter pdl $p is the input parameters (guesses)
140             levmar returns a hash with several elements including a
141             plain text report of the fit, which we chose to print.
142              
143             The interface is flexible-- we could have also called levmar like this
144              
145             $h = levmar($p,$x,$t, ' function
146             x = p0 * exp( -t*t * p1);
147             ');
148              
149             or like this
150              
151             $h = levmar(P =>$p, X => $x, T=> $t, FUNC => ' function
152             x = p0 * exp( -t*t * p1);
153             ');
154              
155             After the fit, the input parameters $p are left
156             unchanged. The output hash $h contains, among other things,
157             the optimized parameters in $h->{P}.
158              
159             =item example--2
160              
161             Next, we do the same fit, but with a perl/PDL fit function.
162              
163             $h = levmar($p,$x,$t, FUNC => sub {
164             my ($p,$x,$t) = @_;
165             my ($p0,$p1) = list $p;
166             $x .= $p0 * exp(-$t*$t * $p1);
167             });
168              
169             Using perl code (second example) results in slower execution
170             than using pure C (first example). How much slower depends
171             on the problem (see L below). See also the
172             section on L.
173              
174             =item example--3
175              
176             Next, we solve the same problem using a C fit routine.
177              
178             levmar($p,$x,$t, FUNC => '
179             #include
180             void gaussian(FLOAT *p, FLOAT *x, int m, int n, FLOAT *t)
181             {
182             int i;
183             for(i=0; i
184             x[i] = p[0] * exp( -t[i]*t[i] * p[1]);
185             }
186             ');
187              
188             The macro C is used rather than float or double because
189             the C code will be used for both single and double precision
190             routines. ( The code is automatically compiled twice; once
191             with C expanded to double and once expanded to float)
192             The correct version is used automatically depending on the
193             type of pdls you give levmar.
194              
195             =item example--4
196              
197             We supply an analytic derivative ( analytic jacobian).
198              
199             $st = '
200             function
201             x = p0 * exp( -t*t * p1);
202              
203             jacobian
204             FLOAT ex, arg;
205             loop
206             arg = -t*t * p1;
207             ex = exp(arg);
208             d0 = ex;
209             d1 = -p0 * t*t * ex ;
210              
211             ';
212              
213             $h = levmar($p,$x,$t, FUNC => $st);
214              
215             If no jacobian function is supplied, levmar automatically
216             uses numeric difference derivatives. You can also explicitly
217             use numeric derivatives with the option C
218             C<< => 'numeric' >>.
219              
220             Note that the directives C and C begin
221             the function definitions. You can also supply a name if
222             you like, eg. C and C.
223              
224             In C, the co-ordinate data is always identified by 't', the
225             ordinate data by 'x' in the fit function and by 'dn', with n a
226             number, in the jacobian. The parameters are identified by
227             'p'. All other identifiers are pure C identifiers and
228             must be defined, as are C and C in the example.
229              
230             Referring to the example above, if the directive C appears
231             on a line by itself, code after it is wrapped in a loop over
232             the data; code before it is not. If C does not appear,
233             then all the code is wrapped in a loop. 'loop' must occur zero
234             or one times in each of the fit and jacobian definitions.
235             For some problems, you will not want a loop at all. In this
236             case the directive C is placed after the declarations.
237              
238             To see what C does, pass the option C C<< => 1 >> to levmar
239             and look at the C source file that is written.
240              
241             When defining the derivatives above (d0, d1) etc., you must
242             put the lines in the proper order ( eg, not d1,d0 ). (This
243             is for efficiency, see the generated C code.)
244              
245             One final note on this example-- we declared C and C to
246             be type C. Because they are temporary variables, we could
247             have hard coded them to double, in which case both the float
248             and double code versions would have used type double for them.
249             This is ok, because it doesn't cost any storage or cause
250             a memory fault because of incorrect pointer arithmetic.
251              
252             =item example--5
253              
254             Here is an example from the liblevmar demo program that shows
255             one more bit of C syntax.
256              
257             $defst = "
258             function modros
259             noloop
260             x0 = 10 * (p1 -p0*p0);
261             x1 = 1.0 - p0;
262             x2 = 100;
263             jacobian jacmodros
264             noloop
265             d0[0] = -20 * p0;
266             d1[0] = 10;
267             d0[1] = -1;
268             d1[1] = 0;
269             d0[2] = 0;
270             d1[2] = 0;
271             ";
272             $p = pdl [-1.2, 1];
273             $x = pdl [0,0,0];
274             $h = levmar( $p,$x, FUNC => $defst );
275              
276             The directive C mentioned above has been used,
277             indicating that there are no implied loops in the
278             function. Note that this model function is designed only for
279             $x->nelem == 3. The additional syntax is in the
280             derivatives. Keeping in mind that there is no loop variable,
281             dq[r] means derivative w.r.t q evaluated at x[r]. (This is
282             translated by C to d[q+r*m], which is the index into a
283             1-d array.)
284              
285             =item example--6
286              
287             Here is an example that uses implicit threading. We create data
288             from a gaussian function with four different sets of parameters
289             and fit it all in one function call.
290              
291             $st = '
292             function
293             x = p0 * exp( -t*t * p1);
294             ';
295              
296             $n = 10;
297             $t = 10 * (sequence($n)/$n -1/2);
298             $x = zeroes($n,4);
299             map { $x(:,$_->[0]) .= $_->[1] * exp(-$t*$t * $_->[2] ) }
300             ( [0,3,.2], [1, 28, .1] , [2,2,.01], [3,3,.3] );
301             $p = [ 5, 1]; # initial guess
302             $h = levmar($p,$x,$t, FUNC => $st );
303             print $h->{P} . "\n";
304              
305             [
306             [ 3 0.2]
307             [ 28 0.1]
308             [ 2 0.01]
309             [ 3 0.3]
310             ]
311              
312             =item example--7
313              
314             This example shows how to fit a bivariate Gaussian. Here
315             is the fit function.
316              
317             sub gauss2d {
318             my ($p,$xin,$t) = @_;
319             my ($p0,$p1,$p2) = list $p;
320             my $n = $t->nelem;
321             my $t1 = $t(:,*$n); # first coordinate
322             my $t2 = $t(*$n,:); # second coordinate
323             my $x = $xin->splitdim(0,$n);
324             $x .= $p0 * exp( -$p1*$t1*$t1 - $p2*$t2*$t2);
325             }
326              
327             We would prefer a function that maps t(n,n) --> x(n,n) (with
328             p viewed as parameters.) But the levmar library expects one
329             dimensional x and t. So we design C to take
330             piddles with these dimensions: C, C,
331             C. For this example, we assume that both the co-ordinate
332             axes run over the same range, so we only need to pass n
333             values for t. The piddles t1 and t2 are (virtual) copies of
334             t with dummy dimensions inserted. Each represents
335             co-ordinate values along each of the two axes at each point
336             in the 2-d space, but independent of the position along the
337             other axis. For instance C and C
338             == t(j)>. We assume that the piddle xin is a flattened
339             version of the ordinate data, so we split the dimensions in
340             x. Then the entire bi-variate gaussian is calculated with
341             one line that operates on 2-d matrices. Now we create some
342             data,
343              
344             my $n = 101; # number of data points along each axis
345             my $scale = 3; # range of co-ordiate data
346             my $t = sequence($n); # co-ordinate data (used for both axes)
347             $t *= $scale/($n-1);
348             $t -= $scale/2; # rescale and shift.
349             my $x = zeroes($n,$n);
350             my $p = pdl [ .5,2,3]; # actual parameters
351             my $xlin = $x->clump(-1); # flatten the x data
352             gauss2d( $p, $xlin, $t->copy); # compute the bivariate gaussian data.
353              
354             Now x contains the ordinate data (so does xlin, but in a flattened shape.)
355             Finally, we fit the data with an incorrect set of initial parameters,
356              
357             my $p1 = pdl [ 1,1,1]; # not the parameters we used to make the data
358             my $h = levmar($p1,$xlin,$t,\&gauss2d);
359              
360             At this point C<$h->{P}> refers to the output parameter piddle C<[0.5, 2, 3]>.
361              
362             =back
363              
364             =head1 CONSTRAINTS
365              
366             Several of the options below are related to constraints. There are
367             three types: box, linear equation, and linear inequality. They may
368             be used in any combination. (But there is no testing if
369             there is a possible solution.) None or one or two of C and C may be
370             specified. None or both of C and C may be specified.
371             None or both of C and C may be specified.
372              
373             =head1 OPTIONS
374              
375             It is best to learn how to call levmar by looking at the
376             examples first, and looking at this section later.
377              
378             levmar() is called like this
379              
380             levmar($arg1, $arg2, ..., OPT1=>$val1, OPT2=>$val2, ...);
381             or this:
382             levmar($arg1, $arg2, ..., {OPT1=>$val1, OPT2=>$val2, ...});
383              
384             When calling levmar, the first 3 piddle arguments (or refs
385             to arrays), if present, are taken to be C<$p>,C<$x>, and C<$t>
386             (parameters, ordinate data, and co-ordinate data) in that
387             order. The first scalar value that can be interpreted as a
388             function will be. Everything else must be passed as an
389             option in a key-value pair. If you prefer, you can pass some
390             or all of C<$p,$x,$t> and the function as key-values in the
391             hash. Note that after the first key-value pair, you cannot
392             pass any more non-hash arguments. The following calls are equivalent
393             (where $func specifies the function as described in L ).
394              
395             levmar($p, $x, $t, $func);
396             levmar($func,$p, $x, $t);
397             levmar($p, $x, $t, FUNC=> $func);
398             levmar($p, $x, T=>$t, FUNC => $func);
399             levmar($p, X=>$x, T=>$t, FUNC => $func);
400             levmar(P=>$p, X=>$x, T=>$t, FUNC => $func);
401              
402             In the following, if the default value is not mentioned, it is undef.
403             C<$outh> refers to the output hash.
404              
405             Some of these options are actually options to Levmar::Func.
406             All options to Levmar::Func may by given in calls to levmar().
407              
408             =over 4
409              
410             =item FUNC
411              
412             This option is required (but it can be passed before the
413             options hash without the key C ) It can be
414             any of the following, which are auto-detected.
415              
416             a string containing lpp code
417             a string containing pure C code
418             the filename of a file containing lpp code (which must end in '.lpp' )
419             the filename of a file containing pure C code ( which must end in '.c' )
420             a reference to perl code
421             a reference to a previously created Levmar::Func object (which was
422             previously created via one of the preceeding methods.)
423              
424             If you are fitting a lot of data by doing many iterations over
425             a loop of perl code, it is by far most efficient to create a Func
426             object from C or lpp code and pass it to levmar. (Implicit threading
427             does not recompile code in any case.)
428              
429             You can also pass pure C code via the option CSRC.
430              
431             =item JFUNC
432              
433             This parameter is the jacobian as a ref to perl CODE. For
434             C and C code, the jacobian, if present, is always in the
435             same source file as the fit function; in this case, you
436             should leave C undefined. See L
437              
438             =item DERIVATIVE
439              
440             This takes the value 'numeric' or 'analytic'. If it is
441             set to 'analytic', but no analytic jacobian of the model
442             function is supplied, then the numeric algorithms will be used
443             anyway.
444              
445             =item NOCLEAN
446              
447             If defined (NOCLEAN => 1), files containing generated C
448             object and dynamic library code are not deleted. If not
449             defined, these files are deleted after they are no longer
450             needed. For the source and object (.c and .o) files, this
451             means immediately after the dynamic library (.so) is built.
452             The dynamic library file is deleted when the corresponding
453             Levmar::Func object is destroyed. (It could be deleted after
454             it is loaded, I suppose, and then be rebuilt if needed
455             again)
456              
457             =item FIX
458              
459             Example: Fix => [1,0,0,1,0].
460             This option takes a pdl (or array ref) of the same shape as
461             the parameters $p. Each element must have the value zero or
462             one. A zero corresponds to a free parameter and a one to a
463             fixed parameter. The best fit is found keeping the fixed
464             parameters at their input values and letting the free
465             parameters vary. This is implemented by using the linear
466             constraint option described below. Each element must be
467             either one or zero. This option currently cannot be
468             threaded. That is, if the array FIX has more than one
469             dimension you will not get correct results. Also, PDL will
470             not add dimension correctly if you pass additional
471             dimensions in other quantities. Threading will work if you
472             use linear constraints directly via C and C.
473              
474             =item FIXB
475              
476             This option is almost the same as FIX. It takes the same
477             values with the same meanings. It fixes parameters at the value
478             of the input parameters, but uses
479             box constraints, i.e., UB and LB rather than linear
480             constraints A and B. You can specify all three of UB,LB, and FIXB.
481             In this case, first box constraints determined by UB and LB are applied
482             Then, for those elements of FIXB with value one, the corresponding
483             values of UB and LB are overridden.
484              
485             =item A
486              
487             Example: A =>pdl [ [1,0], [0,1] ] , B => pdl [ 1,2 ]
488              
489             Minimize with linear constraints $A x $p = $b. That is,
490             parameters $p are optimized over the subset of parameters
491             that solve the equation. The dimensions of the quantities
492             are A(k,m), b(m), p(m), where k is the number of
493             constraints. ( k <= m ). Note that $b is a vector (it has one
494             fewer dimensions than A), but the option key is a capital 'B'.
495              
496             =item B
497              
498             See C.
499              
500             =item UB
501              
502             Example: UB => [10,10,10], LB => [-10,0,-5].
503             Box constraints. These have the same shape as the parameter
504             pdl $p. The fit is done with ub forming upper bounds and lb
505             lower bounds on the parameter values. Use, for instance
506             PDL::Fit::Levmar::get_dbl_max() for parameters that you
507             don't want bounded. You can use either linear constraints or
508             box constraints, or both. That is, you may specify A, B, UB, and LB.
509              
510             =item LB
511              
512             See C.
513              
514             =item WGHTS
515              
516             Penalty weights can be given optionally when box and linear equality
517             constraints are both passed to levmar. See the levmar documenation for
518             how to use this. Note that if C and D are used then the WGHTS must
519             not passed.
520              
521             =item C
522              
523             Example: C => [ [ -1, -2, -1, -1], [ -3, -1, -2, 1] ], D => [ -5, -0.4]
524             Linear inequality constraints. Minimize with constraints $C x $p >= $d.
525             The dimensions are C(k2,m), D(m), p(m).
526              
527             =item D
528              
529             See C
530              
531             =item P
532              
533             Keys P, X, and T can be used to send to the parameters, ordinates and coordinates.
534             Alternatively, you can send them as non-option arguments to levmar before
535             the option arguments.
536              
537             =item X
538              
539             See C

540              
541             =item T
542              
543             See C

544              
545             =item DIR
546              
547             The directory containing files created when compiling C
548             and C fit functions. This defaults to being created by
549             L. The .c,
550             .o, and .so files will be written to this directory. This
551             option actually falls through to levmar_func. Such options
552             should be in separate section, or otherwise noted.
553              
554             =item GETOPTS
555              
556             If defined, return a ref to a hash containing the default
557             values of the parameters.
558              
559             =item COVAR
560              
561             Send a pdl reference for the output hash element COVAR. You may
562             want to test if this option is more efficient for
563             some problem. But unless the covariance matrix is very large,
564             it probably won't help much. On the other hand it almost certainly
565             won't make levmar() less efficient.
566              
567             Note that levmar returns a piddle representing the covariance in
568             the output hash. This will be the the same piddle that you give
569             as input via this option. So, if you do the following,
570              
571             my $covar = PDL->null
572             my $h =levmar(...., COVAR => $covar);
573              
574             then $covar and $h->{COVAR} are references to the same
575             pdl. The storage for the pdl will not be destroyed until
576             both $covar and $h->{COVAR} become undefined.
577              
578             =item NOCOVAR
579              
580             If defined, no covariance matrix is computed.
581              
582             =item POUT
583              
584             Send a pdl reference for the output hash element P. Don't
585             confuse this with the option P which can be used to send the
586             initial guess for the parameters (see C).
587              
588             =item INFO
589              
590             Send a pdl reference for the output hash element C.
591             (see C)
592              
593             =item RET
594              
595             Send a pdl reference for the output hash element C.
596             (see C)
597              
598             =item MAXITS
599              
600             Maximum number of iterations to try before giving up. The default
601             is 100.
602              
603             =item MU
604              
605             The starting value of the parameter mu in the L-M algorithm.
606              
607             =item EPS1, EPS2, EPS3
608              
609             Stopping thresholds for C<||J^T e||_inf>, C<||Dp||_2> and
610             C<||e||_2>. (see the document levmar.pdf by the author of
611             liblevmar and distributed with this module) The algorithm
612             stops when the first threshold is reached (or C is reached). See
613             C for determining which threshold was reached.
614              
615             Here, C is a the vector of errors between the data and
616             the model function and C

is the vector of parameters.

617             S<||J^T e||_inf> is the gradient of C w.r.t C

618             at the current estimate of C

; C<||Dp||_2> is the amount

619             by which C

is currently being shifted at each iteration;

620             C<||e||_2> is a measure of the error between the model function
621             at the current estimate for C

and the data.

622              
623             =item DELTA
624              
625             This is a step size used in computing numeric derivatives. It is
626             not used if the analytic jacobian is used.
627              
628             =item MKOBJ
629              
630             command to compile source into object code. This option is actually set in
631             the Levmar::Func object, but can be given in calls to levmar().
632             The default value is determined by the perl installation and can
633             be determined by examining the Levmar::Func object returned by
634             new or the output hash of a call to levmar. A typical value is
635             cc -c -O2 -fPIC -o %o %c
636              
637             =item MKSO
638              
639             command to convert object code to dynamic library code.
640             This option is actually set in the Levmar::Func object. A
641             typical default value is
642             cc -shared -L/usr/local/lib -fstack-protector %o -o %s
643              
644             =item CTOP
645              
646             The value of this string will be written at the top of the c code
647             written by Levmar::Func. This can be used to include headers and so forth.
648             This option is actually set in the Levmar::Func object. This code is also written
649             at the top of c code translated from lpp code.
650              
651             =item FVERBOSE
652              
653             If true (eg 1) Print the compiling and linking commands to STDERR when compiling fit functions.
654             This option is actually passed to Levmar::Func. Default is 0.
655              
656             =item Default values
657              
658             Here are the default values
659             of some options
660              
661             $Levmar_defaults = {
662             FUNC => undef, # Levmar::Func object, or function def, or ...
663             JFUNC => undef, # must be ref to perl sub
664             MAXITS => 100, # maximum iterations
665             MU => LM_INIT_MU, # These are described in levmar docs
666             EPS1 => LM_STOP_THRESH,
667             EPS2 => LM_STOP_THRESH,
668             EPS3 => LM_STOP_THRESH,
669             DELTA => LM_DIFF_DELTA,
670             DERIVATIVE => 'analytic',
671             FIX => undef,
672             A => undef,
673             B => undef,
674             C => undef,
675             D => undef,
676             UB = undef,
677             LB => undef,
678             X => undef,
679             P => undef,
680             T => undef,
681             WGHTS => undef,
682             # meant to be private
683             LFUNC => undef, # only Levmar::Func object, made from FUNC
684             };
685              
686             =back
687              
688             =head1 OUTPUT
689              
690             This section describes the contents of the hash that
691             levmar takes as output. Do not confuse these hash keys with
692             the hash keys of the input options. It may be a good idea
693             to change the interface by prepending O to all of the output
694             keys that could be confused with options to levmar().
695              
696             =over 3
697              
698             =item P (output)
699              
700             pdl containing the optimized parameters. It has the same shape
701             as the input parameters.
702              
703             =item FUNC (output)
704              
705             ref to the Levmar::Func object. This object may have been created
706             during the call to levmar(). For instance, if you pass a string
707             contiaining an C definition, the compiled object (and associated
708             information) is contained in $outh->{FUNC}. Don't confuse this with
709             the input parameter of the same name.
710              
711             =item COVAR (output)
712              
713             a pdl representing covariance matrix.
714              
715             =item REASON
716              
717             an integer code representing the reason for terminating the
718             fit. (call levmar_report($outh) for an interpretation. The interpretations
719             are listed here as well (see the liblevmar documentation if you don't
720             find an explanation somewhere here.)
721              
722             1 stopped by small gradient J^T e
723             2 stopped by small Dp
724             3 stopped by itmax
725             4 singular matrix. Restart from current p with increased \mu
726             5 no further error reduction is possible. Restart with increased \mu
727             6 stopped by small ||e||_2
728              
729             =item ERRI, ERR1, ERR2, ERR3, ERR4
730              
731             ERRI is C<||e||_2> at the initial paramters. ERR1 through
732             ERR3 are the actual values on termination of the quantities
733             corresponding to the thresholds EPS1 through EPS3 described
734             in the options section. ERR4 is C
735              
736             =item ITS
737              
738             Number of iterations performed
739              
740             =item NFUNC, NJAC, NLS
741              
742             Number of function evaluations, number of jacobian evaluations
743             and number of linear systems solved.
744              
745             =item INFO
746              
747             Array containing ERRI,ERR1, ..., ERR4, ITS, REASON, NFUNC, NJAC, NLS.
748              
749             =back
750              
751             =head1 FIT FUNCTIONS
752              
753             Fit functions, or model functions can be specified in the following
754             ways.
755              
756             =over 3
757              
758             =item lpp
759              
760             It is easier to learn to use C by reading the C section.
761              
762             C processes a function definition into C code. It writes
763             the opening and closing parts of the function, alters a
764             small number of identifiers if they appear, and wraps some
765             of the code in a loop. C recognizes four directives. They
766             must occur on a line with nothing else, not even comments.
767              
768             First, the directives are explained, then the substitutions.
769             The directive lines have a strict format. All other lines
770             can contain any C code including comments and B
771             macros. They will be written to a function in C after the
772             substitutions described below.
773              
774             =over 3
775              
776             =item C
777              
778             The first line of the fit function definition must be
779             C. The first line of the jacobian
780             definition, if the jacobian is to be defined, is C
781             funcname>. The function names can be any valid C function
782             name. The names may also be omitted as they are never needed
783             by the user. The names can be identical. (Note that a
784             numeric suffix will be automatically added to the function
785             name if the .so file already exists. This is because, if
786             another Func object has already loaded the shared library
787             from an .so file, dlopen will use this loaded library for
788             all C objects asking for that .so file, even if the
789             file has been overwritten, causing unexpected behavior)
790              
791             =item C
792              
793             The directive C says that all code before C is not
794             in the implicit loop, while all code following C is in
795             the implicit loop. If you omit the directive, then all the code
796             is wrapped in a loop.
797              
798             =item C
799              
800             The directive C says that there is no implicit loop anywhere
801             in the function.
802              
803             =item Out-of-loop substitutions
804              
805             These substitutions translate C to C in lines that occur
806             before the implied loop (or everywhere if there is no loop.)
807             In every case you can write the translated C code into your
808             function definition yourself and C will leave it
809             untouched.
810              
811             =over 3
812              
813             =item pq -> p[q]
814              
815             where q is a sequence of digits.
816              
817             =item xq -> x[q]
818              
819             where q is a sequence of digits. This is applied only in the fit function,
820             not in the jacobian.
821              
822             =item dq[r] -> d[q+m*r]
823              
824             (where m == $p->nelem), q and r are sequences of
825             digits. This applies only in the jacobian. You usually will
826             only use the fit functions with one value of m. It would
827             make faster code if you were to explicitly write, say C,
828             for each derivative at each point. Presumably there is a
829             small number of data points since this is outside a
830             loop. Some provisions should be added to C, say C to
831             hard code the value of C. But m is only explicitly used in
832             constructions involving this substitution.
833              
834             =back
835              
836             =item In-loop substitutions
837              
838             These substitutions apply inside the implied loop. The loop variables are
839             i in the fit function and i and j in the jacobian.
840              
841             =over 3
842              
843             =item t -> t[i]
844              
845             (literal "i") You can also write t[i] or t[expression involving i] by hand.
846             Example: t*t -> t[i]*t[i].
847              
848             =item pq -> p[q]
849              
850             where q is a sequence of digits. Example p3 -> p[3].
851              
852             =item x -> x[i]
853              
854             only in fit function, not in jacobian.
855              
856             =item (dr or dr[i]) -> d[j++]
857              
858             where r is a sequence of digits. Note that r and i are
859             ignored. So you are required to list the derivatives in
860             order. An example is
861              
862             d0 = t*t; // derivative w.r.t p[0] loop over all points
863             d1 = t;
864              
865             If you write C first and then C, lpp will incorrectly
866             assign the derivative functions.
867              
868             =back
869              
870             =back
871              
872             =item C Code
873              
874             The jacobian name must start with 'jac' when a pure C function definition
875             is used. To see example of fit functions writen in C, call levmar
876             with lpp code and the option C. This will leave the C source
877             in the directory given by C. The C code you supply is mangled
878             slightly before passing it to the compiler: It is copied twice, with
879             FLOAT defined in one case as C and in the other as C.
880             The letter C is also appended to the function names in the latter
881             copy. The C code is parsed to find the fit function name and the
882             jacobian function name.
883              
884             We should make it possible to pass the function names as a separate option
885             rather than parsing the C code. This will allow auxiallary functions to
886             be defined in the C code; something that is currently not possible.
887              
888             =item Perl_Subroutines
889              
890             This is how to use perl subroutines as fit functions... (see
891             the examples for now, e.g. L.) The
892             fit function takes piddles $p,$x, and $t, with dimensions
893             m,n, and tn. (often tn ==n ). These are references with
894             storage already allocated (by the user and liblevmar). So
895             you must use C<.=> when setting values. The jacobian takes
896             piddles $p,$d, and $t, where $d, the piddle of derivatives
897             has dimensions (m,n). For example
898              
899             $f = sub myexp {
900             my ($p,$x,$t) = @_;
901             my ($p0,$p1,$p2) = list($p);
902             $x .= exp($t/$p0);
903             $x *= $p1;
904             $x += $p2
905             }
906              
907             $jf = sub my expjac {
908             my ($p,$d,$t) = @_;
909             my ($p0,$p1,$p2) = list($p);
910             my $arg = $t/$p0;
911             my $ex = exp($arg);
912             $d((0)) .= -$p1*$ex*$arg/$p0;
913             $d((1)) .= $ex;
914             $d((2)) .= 1.0;
915             }
916              
917             =back
918              
919             =head1 PDL::Fit::Levmar::Func Objects
920              
921             These objects are created every time you call levmar(). The hash
922             returned by levmar contains a ref to the Func object. For instance
923             if you do
924              
925             $outh = levmar( FUNC => ..., @opts);
926              
927             then $outh->{LFUNC} will contain a ref to the function object. The .so
928             file, if it exists, will not be deleted until the object is destroyed.
929             This will happen, for instance if you do C<$outh = undef>.
930              
931             =head1 IMPLEMENTATION
932              
933             This section currently only refers to the interface and not the fit algorithms.
934              
935             =over 3
936              
937             =item C fit functions
938              
939             The module does not use perl interfaces to dlopen or the C
940             compiler. The C compiler options are taken from
941             %Config. This is mostly because I had already written those
942             parts before I found the modules. I imagine the
943             implementation here has less overhead, but is less portable.
944              
945             =item perl subroutine fit functions
946              
947             Null pdls are created in C code before the fit starts. They
948             are passed in a struct to the C fit function and derivative
949             routines that wrap the user's perl code. At each call the
950             data pointers to the pdls are set to what liblevmar has sent
951             to the fit functions. The pdls are deleted after the fit.
952             Originally, all the information on the fit functions was
953             supposed to be handled by Levmar::Func. But when I added
954             perl subroutine support, it was less clumsy to move most of
955             the code for perl subs to the Levmar module. So the current
956             solution is not very clean.
957              
958             =item Efficiency
959              
960             Using C or C is faster than using perl subs, which is
961             faster than using L, at least in all the tests I have
962             done. For very large data sets, pure C was twice as fast as
963             perl subs and three times as fast as Fit::LM. Some
964             optimization problems have very small data sets and converge
965             very slowly. As the data sets become smaller and the number
966             of iterations increases the advantage of using pure C
967             increases as expected. Also, if I fit a small data set
968             (n=10) a large number of times (just looping over the same
969             problem), Pure C is ten times faster than Fit::LM, while
970             Levmar with perl subs is only about 1.15 times faster than
971             Fit::LM. All of this was observed on only two different
972             problems.
973              
974             =back
975              
976             =head1 FUNCTIONS
977              
978             =head2 levmar()
979              
980             =for ref
981              
982             Perform Levenberg-Marquardt non-linear least squares fit
983             to data given a model function.
984              
985             =for usage
986              
987             use PDL::Fit::Levmar;
988              
989             $result_hash = levmar($p,$x,$t, FUNC => $func, %OPTIONS );
990              
991             $p is a pdl of input parameters
992             $x is a pdl of ordinate data
993             $t is an optional pdl of co-ordinate data
994            
995             levmar() is the main function in the Levmar package. See the
996             PDL::Fit::Levmar for a complete description.
997              
998             =for signature
999              
1000             p(m); x(n); t(nt); int itmax();
1001             [o] covar(m,m) ; int [o] returnval();
1002             [o] pout(m); [o] info(q=10);
1003              
1004             See the module documentation for information on passing
1005             these arguments to levmar. Threading is known to
1006             work with p(m) and x(n), but I have not tested the rest. In
1007             this case all of they output pdls get the correct number of
1008             dimensions (and correct values !). Notice that t(nt) has a
1009             different dimension than x(n). This is correct because in
1010             some problems there is no t at all, and in some it is
1011             pressed into the service of delivering other parameters to
1012             the fit routine. (Formally, even if you use t(n), they are
1013             parameters.)
1014              
1015             =head2 levmar_chkjac()
1016              
1017             =for ref
1018              
1019             Check the analytic jacobian of a function by computing
1020             the derivatives numerically.
1021              
1022             =for signature
1023            
1024             p(m); t(n); [o] err(n);
1025             This is the relevant part of the signature of the
1026             routine that does the work.
1027              
1028             =for usage
1029              
1030             use PDL::Fit::Levmar;
1031              
1032             $Gh = levmar_func(FUNC=>$Gf);
1033              
1034             $err = levmar_chkjac($Gh,$p,$t);
1035              
1036             $f is an object of type PDL::Fit::Levmar::Func
1037             $p is a pdl of input parameters
1038             $t is an pdl of co-ordinate data
1039             $err is a pdl of errors computed at the values $t.
1040              
1041             Note: No data $x is supplied to this function
1042              
1043             The Func object $Gh contains a function f, and a jacobian
1044             jf. The i_th element of $err measures the agreement between
1045             the numeric and analytic gradients of f with respect to $p
1046             at the i_th evaluation point f (normally determined by the
1047             i_th element of t). A value of 1 means that the analytic and
1048             numeric gradients agree well. A value of 0 mean they do not
1049             agree.
1050              
1051             Sometimes the number of evaluation points n is hardcoded
1052             into the function (as in almost all the examples taken from
1053             liblevmar and appearing in t/liblevmar.t. In this case the
1054             values that f returns depend only on $p and not on any other
1055             external data (nameley t). In this case, you must pass the
1056             number n as a perl scalar in place of t. For example
1057              
1058             $err = levmar_chkjac($Gh,$p,5);
1059              
1060             in the case that f is hardcoded to return five values.
1061              
1062             Need to put the description from the C code in here.
1063              
1064             =head2 levmar_report()
1065              
1066             =for ref
1067              
1068             Make a human readable report from the hash ref returned
1069             by levmar().
1070              
1071             =for usage
1072              
1073             use PDL::Fit::Levmar;
1074              
1075             $h = levmar($p,$x,$t, $func);
1076              
1077             print levmar_report($h);
1078              
1079             =head1 BUGS
1080              
1081             With the levmar-2.5 code: Passing workspace currently does not work with
1082             linear inequality constraint. Some of the PDL threading no long works
1083             correctly. These are noted in the tests in t/thread.t. It is not clear
1084             if it is a threading issue or the fitting has changed.
1085              
1086            
1087             =cut
1088              
1089             #--------------------------------------------------------------------
1090             # Begining of module code
1091              
1092             use strict;
1093             use PDL::Fit::Levmar::Func;
1094             use Carp;
1095             use PDL::NiceSlice;
1096             use PDL::Core ':Internal'; # For topdl()
1097             use vars ( '$Levmar_defaults', '$Levmar_defaults_order',
1098             '$Perl_func_wrapper', '$Perl_jac_wrapper', '$LPPEXT', '$DBLMAX' );
1099              
1100             # 'jac' refers to jacobian
1101             $Perl_func_wrapper = get_perl_func_wrapper();
1102             $Perl_jac_wrapper = get_perl_jac_wrapper();
1103             $DBLMAX = get_dbl_max();
1104              
1105             $LPPEXT = ".lpp";
1106              
1107             sub deb { print STDERR $_[0],"\n"}
1108              
1109             #line 1131 "levmar.pd"
1110             $PDL::Fit::Levmar::HAVE_LAPACK=0;
1111              
1112             #line 1166 "levmar.pd"
1113             # check if dims are equal in two pdls
1114             sub chk_eq_dims {
1115             my ($x,$y) = @_;
1116             my (@xd) = $x->dims();
1117             my (@yd) = $y->dims();
1118             return -2 if (scalar(@xd) != scalar(@yd) );
1119             my $ret = 1;
1120             foreach (@xd) {
1121             return -1 if ($_ != shift(@yd) );
1122             }
1123             return $ret;
1124             }
1125              
1126             @PDL::Fit::Levmar::reason_for_terminating = (
1127             '',
1128             'stopped by small gradient J^T e',
1129             'stopped by small Dp',
1130             'stopped by itmax',
1131             'singular matrix. Restart from current p with increased \mu',
1132             'no further error reduction is possible. Restart with increased \mu',
1133             'stopped by small ||e||_2'
1134             );
1135            
1136             sub levmar_report {
1137             my $h = shift;
1138             make_report($h->{P},$h->{COVAR}, $h->{INFO});
1139             }
1140              
1141             # make a small report out of the results of the optimization
1142             sub make_report {
1143             my ($p,$covar,$info) = @_;
1144             my @ninf = list($info);
1145             # for(my $i=0;$i<9; $i++) { # Tried to get threading to work, but no!
1146             # $ninf[$i] = $info(($i));
1147             # }
1148             $ninf[6] =
1149             $PDL::Fit::Levmar::reason_for_terminating[$ninf[6]]; # replace int with string
1150             my $form = <<"EOFORM";
1151             Estimated parameters: %s
1152             Covariance: %s
1153             ||e||_2 at initial parameters = %g
1154             Errors at estimated parameters:
1155             ||e||_2\t = %g
1156             ||J^T e||_inf\t= %g
1157             ||Dp||_2\t= %g
1158             \\mu/max[J^T J]_ii ]\t= %g
1159             number of iterations\t= %d
1160             reason for termination: = %s
1161             number of function evaluations\t= %d
1162             number of jacobian evaluations\t= %d
1163             number of linear systems solved\t= %d
1164             EOFORM
1165             my $st = sprintf($form, $p,$covar,@ninf);
1166            
1167             }
1168              
1169             $Levmar_defaults_order = qw [
1170             FUNC
1171            
1172              
1173             ];
1174              
1175             $Levmar_defaults = {
1176             MAXITS => 100, # maximum iterations
1177             MU => LM_INIT_MU(),
1178             EPS1 => LM_STOP_THRESH(),
1179             EPS2 => LM_STOP_THRESH(),
1180             EPS3 => LM_STOP_THRESH(),
1181             DELTA => LM_DIFF_DELTA(),
1182             DERIVATIVE => 'analytic',
1183             NOCOVAR => undef,
1184             FIX => undef,
1185             FIXB => undef,
1186             A => undef,
1187             B => undef,
1188             C => undef,
1189             D => undef,
1190             UB => undef,
1191             LB => undef,
1192             FUNC => undef, # Levmar::Func object, or function def, or ...
1193             JFUNC => undef, # must be ref to perl sub
1194             X => undef,
1195             P => undef,
1196             T => undef,
1197             WGHTS => undef,
1198             COVAR => undef, # The next 5 params can be set to PDL->null
1199             POUT => undef, # ref for preallocated output parameters
1200             INFO => undef,
1201             RET => undef,
1202             # meant to be private
1203             LFUNC => undef, # only Levmar::Func object, made from FUNC
1204             };
1205              
1206             # This isn't meant to replace help. But for now its doing nothing.
1207             sub get_help_str {
1208             return '
1209             This is the help string for levmar.
1210              
1211             ';
1212             }
1213              
1214             #################################################################
1215             sub levmar {
1216             my($p,$x,$t,$infunc);
1217             my $args;
1218             # get all args before the hash. p,x,t must come in that order
1219             # but (t), or (t and x), or (t,x,and p) can be in the hash
1220             # the function can be anywhere before the hash
1221             while (1) {
1222             $args = 0;
1223             if ( (not defined $p ) and (ref($_[0]) eq 'PDL' or ref($_[0]) eq 'ARRAY')) {
1224             $p = shift ; $args++;
1225             }
1226             last if ( @_ == 0 );
1227             if ( (not defined $x ) and (ref($_[0]) eq 'PDL' or ref($_[0]) eq 'ARRAY')) {
1228             $x = shift ; $args++;
1229             }
1230             last if ( @_ == 0 );
1231             if ( (not defined $t) and (ref($_[0]) eq 'PDL' or ref($_[0]) eq 'ARRAY')) {
1232             $t = shift ; $args++;
1233             }
1234             last if ( @_ == 0 );
1235             if ( not defined $infunc and ref($_[0]) =~ /Func|CODE/ ) {
1236             $infunc = shift; $args++;
1237             }
1238             last if ( @_ == 0 );
1239             if ( (not defined $infunc) and
1240             ( not ref($_[0]) ) and ( $_[0] =~ /(\.c|$LPPEXT)$/o or $_[0] =~ /\n/ ) ) {
1241             $infunc = shift; $args++;
1242             }
1243             last if ( @_ == 0 or $args == 0);
1244             }
1245             my $inh;
1246             $inh = shift if @_; # input parameter hash
1247             $inh = {} unless defined $inh;
1248             if(ref $inh ne 'HASH') { # turn list into anonymous hash
1249             $inh = defined $inh ? {$inh,@_} : {} ;
1250             }
1251             if( exists $inh->{HELP} ) {
1252             my $s = get_help_str();
1253             return $s;
1254             }
1255             if( exists $inh->{GETOPTS} ) {
1256             my %h = %$Levmar_defaults;
1257             return \%h;
1258             }
1259             # should already use a ref to string here
1260             $inh->{FUNC} = $infunc if defined $infunc;
1261             die "levmar: neither FUNC nor CSRC defined"
1262             unless defined $inh->{FUNC} or defined $inh->{CSRC};
1263              
1264             #line 1323 "levmar.pd"
1265            
1266             foreach (qw( A B C D FIX WGHT )) {
1267             barf "PDL::Fit::Levmar not built with lapack. Found parameter $_"
1268             if exists $inh->{$_};
1269             }
1270            
1271              
1272             #line 1332 "levmar.pd"
1273            
1274             ######## Handle parameters
1275             my $h = {}; # parameter hash to be built from $inh and defaults
1276             my $funch = {}; # unrecognized parameter hash. This will be passed to Func.
1277             foreach ( keys %$Levmar_defaults ){ # copy defaults to final hash
1278             $h->{$_} = $Levmar_defaults->{$_};
1279             }
1280             foreach my $k (keys %$inh ) { # replace defaults with input params
1281             if ( exists $Levmar_defaults->{$k} ) {
1282             $h->{$k} = $inh->{$k};
1283             }
1284             else { # don't recognize, so pass to Func
1285             $funch->{$k} = $inh->{$k};
1286             }
1287             }
1288             ########## Set up input and output variables
1289              
1290             # These must come from parameters if not from the arg list
1291             $p = $h->{P} unless not defined $h->{P} and defined $p;
1292             $x = $h->{X} unless not defined $h->{X} and defined $p;
1293             $t = $h->{T} unless not defined $h->{T} and defined $p;
1294              
1295             if ( not defined $p ) { # This looks like some kind of error thing that was
1296             # not implemented consistently
1297             my $st = "No parameter (P) pdl";
1298             warn $st;
1299             return {RET => -1, ERRS => [$st] };
1300             }
1301             if ( not defined $x ) {
1302             my $st = "No data (X) pdl";
1303             warn $st;
1304             return {RET => -1, ERRS => [$st] };
1305             }
1306              
1307             #-------------------------------------------------
1308             # Treat input and output piddles for pp_defs
1309             $x = topdl($x); # in case they are refs to arrays
1310             $p = topdl($p);
1311             $t = PDL->zeroes($p->type, 1) unless defined $t; # sometimes $t not needed
1312             $t = topdl($t);
1313             ### output variables
1314             my $pout;
1315             my $info;
1316             my $covar;
1317             my $ret;
1318             my $wghts;
1319              
1320             # should put this stuff in a loop
1321             $covar = $h->{COVAR} if defined $h->{COVAR};
1322             $pout = $h->{POUT} if defined $h->{POUT};
1323             $info = $h->{INFO} if defined $h->{INFO};
1324             $ret = $h->{RET} if defined $h->{RET};
1325             $wghts = $h->{WGHTS} if defined $h->{WGHTS};
1326              
1327             # If they are set here, then there will be no external ref.
1328             $covar = PDL->null unless defined $covar;
1329             $pout = PDL->null unless defined $pout;
1330             $info = PDL->null unless defined $info;
1331             $ret = PDL->null unless defined $ret;
1332             $wghts = PDL->null unless defined $wghts;
1333              
1334             # Careful about $m, it is used in construcing $A below (with fix). But this is
1335             # not correct when using implicit threading. Except threading may still be working.
1336             # Need to look into that.
1337             my $m = $p->nelem;
1338              
1339             #--------------------------------------------------------
1340             # Set up Func object
1341             #--------------------------------------------------------
1342             croak "No FUNC in options to levmar." unless exists $h->{FUNC};
1343             if ( ref($h->{FUNC}) =~ /CODE/ or
1344             not ref($h->{FUNC}) ) { # probably a string, convert to func object
1345             $funch->{FUNC} = $h->{FUNC};
1346             my @ret = PDL::Fit::Levmar::Func::levmar_func($funch);
1347             if ($ret[0] == -1 ) { # error in creating function
1348             shift(@ret);
1349             # deb "Error: " . join("\n",@ret); # can turn this off and on
1350             return {RET => -1, ERRS => [@ret] } ; # just return all the other messages.
1351             }
1352             $h->{LFUNC} = $ret[0];
1353             }
1354             else { # already a Func object
1355             $h->{LFUNC} = $h->{FUNC} ; # copy ref
1356             my @k = keys %$funch;
1357             # It would be good to check for valid options. But if a user switches from a
1358             # string to a Func oject in the call to levmar(), he may not delete the
1359             # other keys. Halting on an error would bit frustrating or puzzling.
1360             # Even a warning is perhaps too much
1361             if ( @k ) {
1362             my $s = ''; $s = 's' if @k>1;
1363             my $str = "Unrecognized or useless option$s to levmar: \n";
1364             foreach ( @k ) {
1365             $str .= " '$_' => '" . $funch->{$_} . "'\n" ;
1366             }
1367             warn $str ."";
1368             }
1369             }
1370             # C pointers to fit functions
1371             my ($funcn,$sfuncn,$jacn,$sjacn) = # single and double
1372             $h->{LFUNC}->get_fit_pointers();
1373             my $deriv = $h->{DERIVATIVE};
1374              
1375             # The DFP stuff is to wrap perl functions in C routines to pass to liblevmar.
1376             # It's probably cleaner to move most of this stuff into Levmar::Func
1377             my $DFP = 0; # routines check for $DFP == 0 to bypass perl wrapper
1378              
1379             if ( ref($h->{FUNC}) =~ /CODE/) { # setup perl wrapper stuff
1380             my $jfunc = 0;
1381             $DFP = DFP_create();
1382             if (defined $h->{JFUNC} and ref($h->{JFUNC}) =~ /CODE/) {
1383             $jfunc = $h->{JFUNC};
1384             }
1385             if ( $deriv eq 'analytic' and $jfunc == 0 ) {
1386             # warn "No jacobian function supplied, using numeric derivatives";
1387             $deriv = 'numeric';
1388             $h->{DERIVATIVE} = 'numeric';
1389             }
1390             DFP_set_perl_funcs($DFP, $h->{FUNC}, $h->{JFUNC});
1391             $funcn = $Perl_func_wrapper;
1392             $jacn = $Perl_jac_wrapper;
1393             $sfuncn = $Perl_func_wrapper; # Single and double can use same wrapper
1394             $sjacn = $Perl_jac_wrapper;
1395             }
1396              
1397             ############ Do a few sanity checks
1398              
1399             if ( $deriv eq 'analytic' ) {
1400             if (not defined $jacn or $jacn == 0 ) {
1401             # warn "No jacobian function supplied, using numeric derivatives";
1402             $deriv = 'numeric';
1403             $h->{DERIVATIVE} = 'numeric';
1404             }
1405             }
1406             elsif ( $deriv ne 'numeric' ) {
1407             croak "DERIVATIVE must be 'analytic' or 'numeric'";
1408             }
1409              
1410             # liblevmar uses 5 option for analytic and 6 for numeric.
1411             my $opts = pdl($p->type, @$h{qw(MU EPS1 EPS2 EPS3)},
1412             $h->{DERIVATIVE} eq 'analytic' ? () : $h->{DELTA}
1413             );
1414             # We make an integer option array as well, for passing stuff , like maxits.
1415             my $iopts = pdl(long, $h->{MAXITS});
1416              
1417             ########### FIX holds some parameters constant using linear constraints.
1418             # It is a special case of more general constraints using A and b.
1419             # Notice that this fails if FIX has more than one dimension (ie, you are
1420             # threading. FIXB does the same but using box constraints.
1421              
1422             if (defined $h->{FIX} ) {
1423             my $ip = topdl( $h->{FIX}); # take array ref or pdl
1424             if ( chk_eq_dims($ip,$p) < 0 ) {
1425             croak "p and FIX must have the same dimensions";
1426             }
1427             my $nc = $ip->sum; # number of fixed vars
1428             if ($nc > 0) {
1429             my $A = zeroes($p->type, $m,$nc);
1430             my $b = zeroes($p->type, $nc);
1431             my $j=0;
1432             for(my $i=0; $i<$m; $i++) {
1433             if ($ip->at($i) == 1) {
1434             $A($i,$j) .= 1;
1435             $b($j) .= $p->at($i);
1436             $j++;
1437             }
1438             }
1439             $h->{A} = $A;
1440             $h->{B} = $b;
1441             }
1442             }
1443             elsif ( defined $h->{FIXB} ) {
1444             my $f = topdl( $h->{FIXB}); # take array ref or pdl
1445             if ( chk_eq_dims($f,$p) < 0 ) {
1446             croak "p and FIX must have the same dimensions";
1447             }
1448             $h->{UB} = ones($p) * $DBLMAX if not defined $h->{UB};
1449             $h->{LB} = ones($p) * -$DBLMAX if not defined $h->{LB};
1450             $_ = topdl($_) for @$h{qw(UB LB)};
1451             my $fi = PDL::Primitive::which($f == 1); # indices in p that we want to fix.
1452             $h->{UB}->flat->index($fi) .= $p->flat->index($fi);
1453             $h->{LB}->flat->index($fi) .= $p->flat->index($fi);
1454             # so ub and lb are now at maximum bounds where not fixed and at value of
1455             # p where fixed
1456             }
1457             my $want_covar = 1;
1458             if ( defined $h->{NOCOVAR} ) {
1459             $want_covar = 0;
1460             }
1461              
1462             my $errs = check_levmar_args($h);
1463             if ( @$errs > 0 ) {
1464             # print @$errs;
1465             return {RET => -1, ERRS => $errs };
1466             }
1467             my ($func_key, $arg_list) = build_constraint_arg_combination($h);
1468             # print "func key '$func_key'\n";
1469             if ( not defined $func_key ) {
1470             croak "Could not find function key";
1471             }
1472             if ( not exists $PDL::Fit::Levmar::PDL_Levmar_funcs{$func_key} ) {
1473             croak "Could not find function for key";
1474             }
1475             my $pdl_levmar_func = $PDL::Fit::Levmar::PDL_Levmar_funcs{$func_key};
1476             # print "func $pdl_levmar_func\n";
1477             # my $nargs = @$arg_list;
1478             # print "Got $nargs args\n";
1479             &$pdl_levmar_func($p,$x,$t,@$arg_list,$iopts,$opts,
1480             $covar, $ret, $pout, $info, $funcn, $sfuncn,
1481             ($h->{DERIVATIVE} eq 'analytic' ? ( $jacn, $sjacn ) : ()),
1482             $DFP, $want_covar);
1483              
1484             DFP_free($DFP) if $DFP;
1485              
1486             my $hout = {
1487             RET => $ret,
1488             COVAR => $covar,
1489             P => $pout,
1490             ERRI => $info((0)),
1491             ERR1 => $info((1)),
1492             ERR2 => $info((2)),
1493             ERR3 => $info((3)),
1494             ERR4 => $info((4)),
1495             ITS => $info((5)),
1496             REASON => $info((6)),
1497             NFUNC => $info((7)),
1498             NJAC => $info((8)),
1499             NLS => $info((9)),
1500             INFO => $info,
1501             FUNC => $h->{LFUNC},
1502             };
1503             return $hout;
1504            
1505             } # end levmar()
1506              
1507             sub PDL::Fit::Levmar::check_levmar_args {
1508             my ($h) = @_;
1509             my @refargs = qw( LB UB A B C D );
1510             my @errs = ();
1511             foreach my $argname ( @refargs ) {
1512             if ( exists $h->{$argname} and defined $h->{$argname} ) {
1513             my $arg = $h->{$argname};
1514             if ( not ref($arg) ) {
1515             push @errs, "$argname must be a pdl or ref to array.";
1516             }
1517             }
1518             }
1519             my @combs = ( [ 'A', 'B' ], [ 'C', 'D' ] );
1520             foreach my $comb (@combs ) {
1521             my $n = @$comb;
1522             my $nf = 0;
1523             foreach my $arg ( @$comb ) {
1524             $nf++ if exists $h->{$arg} and defined $h->{$arg};
1525             }
1526             if ( $nf != 0 and $n != $nf ) {
1527             push @errs, 'none or all of ' . join(' and ',@$comb) . ' must be defined.';
1528             }
1529             }
1530             return \@errs;
1531             }
1532              
1533            
1534             # make a list of strings of names of constraint args that
1535             # have been passed.
1536             # hash is arg hash to top level call
1537             sub PDL::Fit::Levmar::build_constraint_arg_combination {
1538             my ($h) = @_;
1539             my @arg_comb = ();
1540             my @arg_list = ();
1541             # order is important in following
1542             my @possible_args = qw( LB UB A B C D );
1543             foreach ( @possible_args ) {
1544             my $ucarg = $_;
1545             # $ucarg =~ tr/a-z/A-Z/; # should rewrite so that tr not needed
1546             if ( exists $h->{$ucarg} and defined $h->{$ucarg} ) {
1547             push @arg_comb, $_;
1548             push @arg_list, topdl($h->{$ucarg});
1549             }
1550             }
1551             my $deriv_type;
1552             if ($h->{DERIVATIVE} eq 'analytic' ) {
1553             $deriv_type = 'DER';
1554             }
1555             else {
1556             $deriv_type = 'DIFF';
1557             }
1558             push @arg_list, topdl($h->{WGHTS}) if exists $h->{WGHTS} and defined $h->{WGHTS};
1559             my $fk = make_pdl_levmar_func_key(make_hash_key_from_arg_comb(\@arg_comb), $deriv_type);
1560             return ($fk,\@arg_list);
1561             }
1562              
1563             sub PDL::Fit::Levmar::make_hash_key_from_arg_comb {
1564             my ( $arg_comb ) = @_;
1565             return join( '_', @$arg_comb);
1566             }
1567              
1568             sub PDL::Fit::Levmar::make_pdl_levmar_func_key {
1569             my ($arg_str, $deriv_type) = @_;
1570             return $deriv_type . '_' . $arg_str;
1571             }
1572              
1573             %PDL::Fit::Levmar::PDL_Levmar_funcs = (
1574             DER_ => \&PDL::levmar_der_,
1575             DIFF_ => \&PDL::levmar_diff_,
1576             DER_LB_C_D => \&PDL::levmar_der_lb_C_d,
1577             DIFF_LB_C_D => \&PDL::levmar_diff_lb_C_d,
1578             DER_A_B => \&PDL::levmar_der_A_b,
1579             DIFF_A_B => \&PDL::levmar_diff_A_b,
1580             DER_UB_A_B => \&PDL::levmar_der_ub_A_b,
1581             DIFF_UB_A_B => \&PDL::levmar_diff_ub_A_b,
1582             DER_UB => \&PDL::levmar_der_ub,
1583             DIFF_UB => \&PDL::levmar_diff_ub,
1584             DER_A_B_C_D => \&PDL::levmar_der_A_b_C_d,
1585             DIFF_A_B_C_D => \&PDL::levmar_diff_A_b_C_d,
1586             DER_LB_UB_A_B_C_D => \&PDL::levmar_der_lb_ub_A_b_C_d,
1587             DIFF_LB_UB_A_B_C_D => \&PDL::levmar_diff_lb_ub_A_b_C_d,
1588             DER_LB => \&PDL::levmar_der_lb,
1589             DIFF_LB => \&PDL::levmar_diff_lb,
1590             DER_LB_A_B_C_D => \&PDL::levmar_der_lb_A_b_C_d,
1591             DIFF_LB_A_B_C_D => \&PDL::levmar_diff_lb_A_b_C_d,
1592             DER_UB_A_B_C_D => \&PDL::levmar_der_ub_A_b_C_d,
1593             DIFF_UB_A_B_C_D => \&PDL::levmar_diff_ub_A_b_C_d,
1594             DER_LB_UB => \&PDL::levmar_der_lb_ub,
1595             DIFF_LB_UB => \&PDL::levmar_diff_lb_ub,
1596             DER_LB_A_B => \&PDL::levmar_der_lb_A_b,
1597             DIFF_LB_A_B => \&PDL::levmar_diff_lb_A_b,
1598             DER_UB_C_D => \&PDL::levmar_der_ub_C_d,
1599             DIFF_UB_C_D => \&PDL::levmar_diff_ub_C_d,
1600             DER_LB_UB_A_B => \&PDL::levmar_der_lb_ub_A_b,
1601             DIFF_LB_UB_A_B => \&PDL::levmar_diff_lb_ub_A_b,
1602             DER_LB_UB_C_D => \&PDL::levmar_der_lb_ub_C_d,
1603             DIFF_LB_UB_C_D => \&PDL::levmar_diff_lb_ub_C_d,
1604             DER_C_D => \&PDL::levmar_der_C_d,
1605             DIFF_C_D => \&PDL::levmar_diff_C_d,
1606             );
1607              
1608             sub levmar_chkjac {
1609             my ($f,$p,$t) = @_;
1610             my $r = ref $f;
1611             if ( not $r =~ /Levmar::Func/ ) {
1612             warn "levmar_chkjac: not a Levmar::Func object ";
1613             return;
1614             }
1615             my $N;
1616             if ( not ref($t) =~ /PDL/ ) {
1617             $N = $t; # in case there is no t for this func
1618             $t = zeroes( $p->type, 1); just some pdl
1619             }
1620             my $DFP = 0;
1621             my ($funcn,$sfuncn,$jacn,$sjacn);
1622             if ( ref($f->{FUNC}) =~ /CODE/) { # setup perl wrapper stuff
1623             my $jfunc = 0;
1624             $DFP = DFP_create();
1625             if (not (defined $f->{JFUNC} and ref($f->{FUNC}) =~ /CODE/ ) ) {
1626             warn "levmar_chkjac: no perl code jacobian supplied in JFUNC.";
1627             return undef;
1628             }
1629             DFP_set_perl_funcs($DFP, $f->{FUNC}, $f->{JFUNC});
1630             $funcn = $Perl_func_wrapper;
1631             $jacn = $Perl_jac_wrapper;
1632             $sfuncn = $Perl_func_wrapper;
1633             $sjacn = $Perl_jac_wrapper;
1634             }
1635             else { # pointers to native c functions.
1636             ($funcn,$sfuncn,$jacn,$sjacn) =
1637             $f->get_fit_pointers();
1638             }
1639             my $err;
1640             if ( defined $N ) {
1641             $err = _levmar_chkjac_no_t($p,$funcn,$sfuncn,$jacn,$sjacn,$N,$DFP);
1642             }
1643             else {
1644             $err = _levmar_chkjac($p,$t,$funcn,$sfuncn,$jacn,$sjacn,$DFP);
1645             }
1646             DFP_free($DFP);
1647             return $err;
1648             }
1649             #line 1650 "Levmar.pm"
1650              
1651             *levmar_der_ = \&PDL::levmar_der_;
1652              
1653              
1654              
1655              
1656             *levmar_der_lb_ub = \&PDL::levmar_der_lb_ub;
1657              
1658              
1659              
1660              
1661             *levmar_der_ub = \&PDL::levmar_der_ub;
1662              
1663              
1664              
1665              
1666             *levmar_der_lb = \&PDL::levmar_der_lb;
1667              
1668              
1669              
1670              
1671             *levmar_diff_ = \&PDL::levmar_diff_;
1672              
1673              
1674              
1675              
1676             *levmar_diff_lb_ub = \&PDL::levmar_diff_lb_ub;
1677              
1678              
1679              
1680              
1681             *levmar_diff_ub = \&PDL::levmar_diff_ub;
1682              
1683              
1684              
1685              
1686             *levmar_diff_lb = \&PDL::levmar_diff_lb;
1687              
1688              
1689              
1690              
1691             *_levmar_chkjac = \&PDL::_levmar_chkjac;
1692              
1693              
1694              
1695              
1696             *_levmar_chkjac_no_t = \&PDL::_levmar_chkjac_no_t;
1697              
1698              
1699              
1700              
1701              
1702              
1703              
1704             #line 1133 "levmar.pd"
1705              
1706             =head1 AUTHORS
1707              
1708             PDL code for Levmar Copyright (C) 2006 John Lapeyre. C
1709             library code Copyright (C) 2006 Manolis Lourakis, licensed
1710             here under the Gnu Public License.
1711              
1712             All rights reserved. There is no warranty. You are allowed
1713             to redistribute this software / documentation under certain
1714             conditions. For details, see the file COPYING in the PDL
1715             distribution. If this file is separated from the PDL
1716             distribution, the copyright notice should be included in the
1717             file.
1718              
1719             =cut
1720             #line 1721 "Levmar.pm"
1721              
1722             # Exit with OK status
1723              
1724             1;