| 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 |
||||||
| 40 | library levmar 2.5 (written in C). Levmar is | ||||||
| 41 | L |
||||||
| 42 | or finite difference derivatives (in case no analytic | ||||||
| 43 | derivatives are supplied), L |
||||||
| 44 | and/or L |
||||||
| 45 | constraints (with L |
||||||
| 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 |
||||||
| 54 | and B |
||||||
| 55 | F |
||||||
| 56 | C |
||||||
| 57 | the fitting options C, C, C |
||||||
| 58 | not be used. All other options, including C |
||||||
| 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 |
||||||
| 64 | transparently translated to C, compiled, and dynamically | ||||||
| 65 | linked. Fit functions may also be written in pure C. If C | ||||||
| 66 | or C |
||||||
| 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 |
||||||
| 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 | ||||||
| 138 | The fit function in this example is in C |
||||||
| 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 |
||||||
| 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 |
||||||
| 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 |
||||||
| 221 | the function definitions. You can also supply a name if | ||||||
| 222 | you like, eg. C |
||||||
| 223 | |||||||
| 224 | In C |
||||||
| 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 |
||||||
| 229 | |||||||
| 230 | Referring to the example above, if the directive C |
||||||
| 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 |
||||||
| 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 |
||||||
| 237 | |||||||
| 238 | To see what C |
||||||
| 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 |
||||||
| 246 | be type C |
||||||
| 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 |
||||||
| 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 |
||||||
| 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 |
||||||
| 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 |
||||||
| 330 | piddles with these dimensions: C , C |
||||||
| 331 | C |
||||||
| 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 | ||||||
| 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 |
||||||
| 370 | specified. None or both of C and C may be specified. | ||||||
| 371 | None or both of C |
||||||
| 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 |
||||||
| 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 |
||||||
| 435 | same source file as the fit function; in this case, you | ||||||
| 436 | should leave C |
||||||
| 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 |
||||||
| 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 |
||||||
| 613 | C |
||||||
| 614 | |||||||
| 615 | Here, C |
||||||
| 616 | the model function and C is the vector of parameters. |
||||||
| 617 | S<||J^T e||_inf> is the gradient of 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 |
||||||
| 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 |
||||||
| 761 | |||||||
| 762 | C |
||||||
| 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 |
||||||
| 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 |
||||||
| 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 |
||||||
| 789 | file has been overwritten, causing unexpected behavior) | ||||||
| 790 | |||||||
| 791 | =item C |
||||||
| 792 | |||||||
| 793 | The directive C |
||||||
| 794 | in the implicit loop, while all code following C |
||||||
| 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 |
||||||
| 801 | in the function. | ||||||
| 802 | |||||||
| 803 | =item Out-of-loop substitutions | ||||||
| 804 | |||||||
| 805 | These substitutions translate C |
||||||
| 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 |
||||||
| 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 |
||||||
| 831 | hard code the value of C |
||||||
| 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 |
||||||
| 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 |
||||||
| 877 | in the directory given by C |
||||||
| 878 | slightly before passing it to the compiler: It is copied twice, with | ||||||
| 879 | FLOAT defined in one case as C |
||||||
| 880 | The letter C |
||||||
| 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 |
||||||
| 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 |
||||||
| 961 | faster than using L |
||||||
| 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; |