File Coverage

blib/lib/PDL/Func.pm
Criterion Covered Total %
statement 188 240 78.3
branch 59 126 46.8
condition 9 22 40.9
subroutine 22 25 88.0
pod 12 12 100.0
total 290 425 68.2


line stmt bran cond sub pod time code
1             =encoding utf8
2              
3             =head1 NAME
4              
5             PDL::Func - interpolation, integration, & gradient estimation (differentiation) of functions
6              
7             =head1 SYNOPSIS
8              
9             use PDL::Func;
10             use PDL::Math;
11              
12             # somewhat pointless way to estimate cos and sin,
13             # but is shows that you can broadcast if you want to
14             # (and the library lets you)
15             #
16             my $obj = PDL::Func->init( Interpolate => "Hermite" );
17             #
18             my $x = pdl( 0 .. 45 ) * 4 * 3.14159 / 180;
19             my $y = cat( sin($x), cos($x) );
20             $obj->set( x => $x, y => $y, bc => "simple" );
21             #
22             my $xi = pdl( 0.5, 1.5, 2.5 );
23             my $yi = $obj->interpolate( $xi );
24             #
25             print "sin( $xi ) equals ", $yi->slice(':,(0)'), "\n";
26             sin( [0.5 1.5 2.5] ) equals [0.87759844 0.070737667 -0.80115622]
27             #
28             print "cos( $xi ) equals ", $yi->slice(':,(1)'), "\n";
29             cos( [0.5 1.5 2.5] ) equals [ 0.4794191 0.99768655 0.59846449]
30             #
31             print sin($xi), "\n", cos($xi), "\n";
32             [0.47942554 0.99749499 0.59847214]
33             [0.87758256 0.070737202 -0.80114362]
34              
35             =head1 DESCRIPTION
36              
37             This module aims to provide a uniform interface
38             to the various interpolation methods available to PDL.
39             The idea is that a different interpolation scheme
40             can be used just by changing an attribute of a C
41             object.
42             Some interpolation schemes (as exemplified by the SLATEC
43             library) also provide additional functionality, such as
44             integration and gradient estimation.
45              
46             Throughout this documentation, C<$x> and C<$y> refer to the function
47             to be interpolated whilst C<$xi> and C<$yi> are the interpolated values.
48              
49             The available types, or I, of interpolation are listed below.
50             Also given are the valid attributes for each scheme: the flag value
51             indicates whether it can be set (s), got (g), and if it is
52             required (r) for the method to work.
53              
54             =head2 Interpolate => Linear
55              
56             An extravagent way of calling the linear interpolation routine
57             L.
58              
59             The valid attributes are:
60              
61             Attribute Flag Description
62             x sgr x positions of data
63             y sgr function values at x positions
64             err g error flag
65              
66             =head2 Interpolate => Hermite
67              
68             Use the piecewise cubic Hermite interpolation routines
69             from the SLATEC library.
70              
71             The valid attributes are:
72              
73             Attribute Flag Description
74             x sgr x positions of data
75             y sgr function values at x positions
76             bc sgr boundary conditions
77             g g estimated gradient at x positions
78             err g error flag
79              
80             Given the initial set of points C<(x,y)>, an estimate of the
81             gradient is made at these points, using the given boundary
82             conditions. The gradients are stored in the C attribute,
83             accessible via:
84              
85             $gradient = $obj->get( 'g' );
86              
87             However, as this gradient is only calculated 'at the last moment',
88             C will only contain data I one of
89             C, C, or C is used.
90              
91             =head3 Boundary conditions for the Hermite routines
92              
93             If your data is monotonic, and you are not too bothered about
94             edge effects, then the default value of C of C is for you.
95             Otherwise, take a look at the description of
96             L and use a hash reference
97             for the C attribute, with the following keys:
98              
99             =over 3
100              
101             =item monotonic
102              
103             0 if the interpolant is to be monotonic in each interval (so
104             the gradient will be 0 at each switch point),
105             otherwise the gradient is calculated using a 3-point difference
106             formula at switch points.
107             If E 0 then the interpolant is forced to lie close to the
108             data, if E 0 no such control is imposed.
109             Default = B<0>.
110              
111             =item start
112              
113             A perl list of one or two elements. The first element defines how the
114             boundary condition for the start of the array is to be calculated;
115             it has a range of C<-5 .. 5>, as given for the C parameter
116             of L.
117             The second element, only used if options 2, 1, -1, or 2
118             are chosen, contains the value of the C parameter.
119             Default = B<[ 0 ]>.
120              
121             =item end
122              
123             As for C, but for the end of the data.
124              
125             =back
126              
127             An example would be
128              
129             $obj->set( bc => { start => [ 1, 0 ], end => [ 1, -1 ] } )
130              
131             which sets the first derivative at the first point to 0,
132             and at the last point to -1.
133              
134             =head2 Interpolate => CSpline
135              
136             Use the cubic spline interpolation routines
137             from the SLATEC library's PCHIP package.
138              
139             The valid attributes are:
140              
141             Attribute Flag Description
142             x sgr x positions of data
143             y sgr function values at x positions
144             bc sgr boundary conditions (see Hermite but no "simple" or monotonic)
145             g g estimated gradient at x positions
146             err g error flag
147              
148             Given the initial set of points C<(x,y)>, an estimate of the
149             gradient is made at these points, using the given parameters.
150             The gradients are stored in the C attribute,
151             accessible via:
152              
153             $gradient = $obj->get( 'g' );
154              
155             However, as this gradient is only calculated 'at the last moment',
156             C will only contain data I one of
157             C, C, or C is used.
158              
159             =head2 Errors
160              
161             The C method provides a simple mechanism to check if
162             the previous method was successful.
163             If the function returns an error flag, then it is stored
164             in the C attribute.
165             To find out which routine was used, use the L method.
166              
167             =cut
168              
169             package PDL::Func;
170              
171 1     1   774 use strict;
  1         2  
  1         41  
172 1     1   7 use warnings;
  1         1  
  1         51  
173 1     1   7 use Carp;
  1         3  
  1         76  
174 1     1   542 use parent qw(PDL::Exporter);
  1         355  
  1         8  
175             our @EXPORT_OK = qw(pchip spline);
176             our %EXPORT_TAGS = (Func=>[@EXPORT_OK]);
177              
178             ####################################################################
179             ## Public routines:
180              
181             =head1 FUNCTIONS
182              
183             =head2 init
184              
185             =for usage
186              
187             $obj = PDL::Func->init( Interpolate => "Hermite", x => $x, y => $y );
188             $obj = PDL::Func->init( { x => $x, y => $y } );
189              
190             =for ref
191              
192             Create a PDL::Func object, which can interpolate, and possibly
193             integrate and calculate gradients of a dataset.
194              
195             If not specified, the value of Interpolate is taken to be
196             C, which means the interpolation is performed by
197             L.
198             A value of C uses piecewise cubic Hermite functions,
199             which also allows the integral and gradient of the data
200             to be estimated.
201              
202             Options can either be provided directly to the method, as in the
203             first example, or within a hash reference, as shown in the second
204             example.
205              
206             =cut
207              
208             # meaning of types:
209             # required - required, if this attr is changed, we need to re-initialise
210             # settable - can be changed with a init() or set() command
211             # gettable - can be read with a get() command
212             #
213             # do we really need gettable? Not currently, that's for sure,
214             # as everything is gettable
215              
216             my %attr =
217             (
218             Default => {
219             x => { required => 1, settable => 1, gettable => 1 },
220             y => { required => 1, settable => 1, gettable => 1 },
221             err => { gettable => 1 },
222             },
223             Linear => {},
224             Hermite => {
225             bc => { settable => 1, gettable => 1, required => 1, default => "simple" },
226             g => { gettable => 1 },
227             },
228             CSpline => {
229             bc => { settable => 1, gettable => 1, required => 1, default => {} },
230             g => { gettable => 1 },
231             t => { gettable => 1 },
232             a => { gettable => 1 },
233             },
234             );
235              
236             sub init {
237 3     3 1 22 my $this = shift;
238 3   33     18 my $class = ref($this) || $this;
239              
240             # class structure
241 3         8 my $self = { };
242              
243             # make $self into an object
244 3         8 bless $self, $class;
245              
246             # set up default attributes
247             #
248 3         14 my ( %opt ) = @_;
249 3 100       13 $opt{Interpolate} = "Linear" unless exists $opt{Interpolate};
250              
251             # set variables
252 3         18 $self->set( %opt );
253              
254             # return the object
255 3         13 return $self;
256             } # sub: init()
257              
258             #####################################################################
259              
260             # $self->_init_attr( $interpolate )
261             #
262             # set up the object for the given interpolation method
263             # - uses the values stored in %attr to fill in the
264             # fields in $self AFTER clearing the object
265             #
266             # NOTE: called by set()
267             #
268             sub _init_attr {
269 4     4   8 my $self = shift;
270 4         47 my $interpolate = shift;
271              
272             croak "ERROR: Unknown interpolation scheme <$interpolate>.\n"
273 4 50       17 unless defined $attr{$interpolate};
274              
275             # clear out the old data (if it's not the first time through)
276 4         20 $self->{attributes} = {};
277 4         18 $self->{values} = {};
278 4         21 $self->{types} = { required => 0, settable => 0, gettable => 0 };
279 4         21 $self->{flags} = { scheme => $interpolate, status => 1, routine => "none", changed => 1 };
280              
281             # set up default values
282 4         10 my $ref = $attr{Default};
283 4         9 foreach my $attr ( keys %{$ref} ) {
  4         16  
284             # set default values
285 12         19 foreach my $type ( keys %{$self->{types}} ) {
  12         47  
286 36         95 $self->{attributes}{$attr}{$type} = $self->{types}{$type};
287             }
288              
289             # change the values to those supplied
290 12         27 foreach my $type ( keys %{$ref->{$attr}} ) {
  12         30  
291             $self->{attributes}{$attr}{$type} = $ref->{$attr}{$type}
292 28 50       135 if exists $self->{types}{$type};
293             }
294             # set value to undef
295 12         35 $self->{values}{$attr} = undef;
296             }
297              
298             # now set up for the particular interpolation scheme
299 4         11 $ref = $attr{$interpolate};
300 4         8 foreach my $attr ( keys %{$ref} ) {
  4         14  
301             # set default values, if not known
302 8 50       24 unless ( defined $self->{attributes}{$attr} ) {
303 8         11 foreach my $type ( keys %{$self->{types}} ) {
  8         222  
304 24         59 $self->{attributes}{$attr}{$type} = $self->{types}{$type};
305             }
306             }
307              
308             # change the values to those supplied
309 8         16 foreach my $type ( keys %{$ref->{$attr}} ) {
  8         23  
310 17 100       39 next if $type eq "default";
311             $self->{attributes}{$attr}{$type} = $ref->{$attr}{$type}
312 14 50       41 if exists $self->{types}{$type};
313             }
314             # set value to default value/undef
315             $self->{values}{$attr} =
316 8 100       30 exists $ref->{$attr}{default} ? $ref->{$attr}{default} : undef;
317             }
318             } # sub: _init_attr()
319              
320             ####################################################################
321              
322             # call this at the start of each method that needs data
323             # stored in the object. This function ensures that all required
324             # attributes exist and, if necessary, re-initialises the object
325             # - ie if the data has changed.
326             #
327             sub _check_attr {
328 7     7   13 my $self = shift;
329 7 50       24 return unless $self->{flags}{changed};
330              
331 7         12 my @emsg;
332 7         14 foreach my $name ( sort keys %{ $self->{attributes} } ) {
  7         48  
333 35 100       90 if( $self->{attributes}{$name}{required} ) {
334 20 50       54 push @emsg, $name unless defined($self->{values}{$name});
335             }
336             }
337 7 50       22 croak "ERROR - the following attributes must be supplied:\n [ @emsg ]\n"
338             if @emsg;
339              
340 7         19 $self->{flags}{routine} = "none";
341 7         14 $self->{flags}{status} = 1;
342              
343 7         19 $self->_initialise;
344 7         32 $self->{flags}{changed} = 0;
345              
346             } # sub: _check_attr()
347              
348             ####################################################################
349              
350             # for a given scheme, it may be necessary to perform certain
351             # operations before the main routine of a method is called.
352             # It's done here.
353             #
354             # Due to lazy evaluation we try to do this as late as possible -
355             # _initialise() should only be called by _check_attr()
356             # [ at least at the moment ]
357             #
358             sub _initialise {
359 7     7   15 my $self = shift;
360 7         17 my $iflag = $self->scheme();
361 7 100       23 if ( $iflag eq "Hermite") {
362 5         12 _init_hermite( $self );
363             }
364 7 100       65 if ( $iflag eq "CSpline" ) {
365 1         4 _init_cspline( $self );
366             }
367             } # sub: _initialise()
368              
369             # something has changed, so we need to recalculate the gradient
370             # - actually, some changes don't invalidate the gradient,
371             # however, with the current design, it's impossible to know
372             # this. (poor design)
373             #
374             sub _init_hermite {
375 5     5   8 my $self = shift;
376              
377             # set up error flags
378 5         11 $self->{flags}{status} = 0;
379 5         10 $self->{flags}{routine} = "none";
380              
381             # get values in one go
382 5         14 my ( $x, $y, $bc ) = $self->_get_value( qw( x y bc ) );
383              
384             # check 1st dimension of x and y are the same
385             # ie allow the possibility of broadcasting
386 5         26 my $xdim = $x->getdim( 0 );
387 5         15 my $ydim = $y->getdim( 0 );
388 5 50       15 croak "ERROR: x and y ndarrays must have the same first dimension.\n"
389             unless $xdim == $ydim;
390              
391 5         10 my ( $g, $ierr );
392 5 100       18 if ( ref($bc) eq "HASH" ) {
    50          
393 1   50     9 my $monotonic = $bc->{monotonic} || 0;
394 1   50     9 my $start = $bc->{start} || [ 0 ];
395 1   50     7 my $end = $bc->{end} || [ 0 ];
396              
397 1         4 my $ic = [$start->[0], $end->[0]];
398 1 50       7 my $vc = [@$start == 2 ? $start->[1] : 0, @$end == 2 ? $end->[1] : 0];
    50          
399              
400 1         195 ( $g, $ierr ) = PDL::Primitive::pchip_chic( $ic, $vc, $monotonic, $x, $y );
401              
402 1         8 $self->{flags}{routine} = "pchip_chic";
403              
404             } elsif ( $bc eq "simple" ) {
405 4         278 ( $g, $ierr ) = PDL::Primitive::pchip_chim( $x, $y );
406 4         19 $self->{flags}{routine} = "pchip_chim";
407              
408             } else {
409             # Unknown boundary condition
410 0         0 croak "ERROR: unknown boundary condition <$bc>.\n";
411             # return;
412             }
413              
414 5         20 $self->_set_value( g => $g, err => $ierr );
415              
416 5 50       22 if ( all $ierr == 0 ) {
    0          
417             # everything okay
418 5         23 $self->{flags}{status} = 1;
419             } elsif ( any $ierr < 0 ) {
420             # a problem
421 0         0 $self->{flags}{status} = 0;
422             } else {
423             # there were switches in monotonicity
424 0         0 $self->{flags}{status} = -1;
425             }
426             }
427              
428             sub _init_cspline {
429 1     1   2 my $self = shift;
430             # set up error flags
431 1         4 $self->{flags}{status} = 0;
432 1         3 $self->{flags}{routine} = "none";
433 1         4 my ( $x, $y, $bc ) = $self->_get_value( qw( x y bc ) );
434             # check 1st dimension of x and y are the same
435             # ie allow the possibility of broadcasting
436 1         6 my $xdim = $x->getdim( 0 );
437 1         4 my $ydim = $y->getdim( 0 );
438 1 50       4 croak "ERROR: x and y ndarrays must have the same first dimension.\n"
439             unless $xdim == $ydim;
440 1         3 my ( $g, $ierr );
441 1 50       6 if ( ref($bc) eq "HASH" ) {
442 1   50     8 my $start = $bc->{start} || [ 0 ];
443 1   50     6 my $end = $bc->{end} || [ 0 ];
444 1         3 my $ic = [$start->[0], $end->[0]];
445 1 50       7 my $vc = [@$start == 2 ? $start->[1] : 0, @$end == 2 ? $end->[1] : 0];
    50          
446 1         120 ( $g, $ierr ) = PDL::Primitive::pchip_chsp( $ic, $vc, $x, $y );
447 1         7 $self->{flags}{routine} = "pchip_chsp";
448             }
449 1         5 $self->_set_value( g => $g, err => $ierr );
450 1 50       5 if ( all $ierr == 0 ) {
    0          
451             # everything okay
452 1         6 $self->{flags}{status} = 1;
453             } elsif ( any $ierr < 0 ) {
454             # a problem
455 0         0 $self->{flags}{status} = 0;
456             }
457             }
458              
459             ####################################################################
460             ####################################################################
461              
462             # a version of set that ignores the settable flag
463             # and doesn't bother about the presence of an Interpolate
464             # value.
465             #
466             # - for use by the class, not by the public
467             #
468             # it still ignores unknown attributes
469             #
470             sub _set_value {
471 13     13   24 my $self = shift;
472 13         91 my %attrs = ( @_ );
473 13         43 foreach my $attr ( keys %attrs ) {
474 19 50       54 if ( exists($self->{values}{$attr}) ) {
475 19         69 $self->{values}{$attr} = $attrs{$attr};
476 19         54 $self->{flags}{changed} = 1;
477             }
478             }
479             } # sub: _set_value()
480              
481             # a version of get that ignores the gettable flag
482             # - for use by the class, not by the public
483             #
484             # an unknown attribute returns an undef
485             #
486             sub _get_value {
487 18     18   26 my $self = shift;
488              
489 18         31 my @ret;
490 18         55 foreach my $name ( @_ ) {
491 38 50       91 if ( exists $self->{values}{$name} ) {
492 38         97 push @ret, $self->{values}{$name};
493             } else {
494 0         0 push @ret, undef;
495             }
496             }
497              
498 18 100       65 return wantarray ? @ret : $ret[0];
499              
500             } # sub: _get_value()
501              
502             ####################################################################
503              
504             =head2 set
505              
506             =for usage
507              
508             my $nset = $obj->set( x => $newx, y => $newy );
509             my $nset = $obj->set( { x => $newx, y => $newy } );
510              
511             =for ref
512              
513             Set attributes for a PDL::Func object.
514              
515             The return value gives the number of the supplied attributes
516             which were actually set.
517              
518             =cut
519              
520             sub set {
521 6     6 1 35 my $self = shift;
522 6 50       21 return if !@_;
523              
524 6         36 my $vref;
525 6 50 33     26 if ( @_ == 1 and ref($_[0]) eq "HASH" ) {
526 0         0 $vref = shift;
527             } else {
528 6         23 my %vals = ( @_ );
529 6         18 $vref = \%vals;
530             }
531              
532             # initialise attributes IFF Interpolate
533             # is specified
534             #
535             $self->_init_attr( $vref->{Interpolate} )
536 6 100       32 if exists $vref->{Interpolate};
537              
538 6         12 my $ctr = 0;
539 6         10 foreach my $name ( keys %{$vref} ) {
  6         19  
540 15 100       32 next if $name eq "Interpolate";
541 11 50       31 if ( exists $self->{attributes}{$name}{settable} ) {
542 11         27 $self->{values}{$name} = $vref->{$name};
543 11         20 $ctr++;
544             }
545             }
546              
547 6 50       23 $self->{flags}{changed} = 1 if $ctr;
548 6         12 $self->{flags}{status} = 1;
549 6         23 return $ctr;
550              
551             } # sub: set()
552              
553             ####################################################################
554              
555             =head2 get
556              
557             =for usage
558              
559             my $x = $obj->get( x );
560             my ( $x, $y ) = $obj->get( qw( x y ) );
561              
562             =for ref
563              
564             Get attributes from a PDL::Func object.
565              
566             Given a list of attribute names, return a list of
567             their values; in scalar mode return a scalar value.
568             If the supplied list contains an unknown attribute,
569             C returns a value of C for that
570             attribute.
571              
572             =cut
573              
574             sub get {
575 2     2 1 6 my $self = shift;
576              
577 2         4 my @ret;
578 2         5 foreach my $name ( @_ ) {
579 2 50       11 if ( exists $self->{attributes}{$name}{gettable} ) {
580 2         8 push @ret, $self->{values}{$name};
581             } else {
582 0         0 push @ret, undef;
583             }
584             }
585              
586 2 100       42 return wantarray ? @ret : $ret[0];
587              
588             } # sub: get()
589              
590             ####################################################################
591             #
592             # access to flags - have individual methods for these
593              
594             =head2 scheme
595              
596             =for usage
597              
598             my $scheme = $obj->scheme;
599              
600             =for ref
601              
602             Return the type of interpolation of a PDL::Func object.
603              
604             Returns either C, C, or C.
605              
606             =cut
607              
608 17     17 1 332 sub scheme { return $_[0]->{flags}{scheme}; }
609              
610             =head2 status
611              
612             =for usage
613              
614             my $status = $obj->status;
615              
616             =for ref
617              
618             Returns the status of a PDL::Func object.
619              
620             This method provides a high-level indication of
621             the success of the last method called
622             (except for C which is ignored).
623             Returns B<1> if everything is okay, B<0> if
624             there has been a serious error,
625             and B<-1> if there
626             was a problem which was not serious.
627             In the latter case, C<$obj-Eget("err")> may
628             provide more information, depending on the
629             particular scheme in use.
630              
631             =cut
632              
633 8     8 1 51 sub status { return $_[0]->{flags}{status}; }
634              
635             =head2 routine
636              
637             =for usage
638              
639             my $name = $obj->routine;
640              
641             =for ref
642              
643             Returns the name of the last routine called by a PDL::Func object.
644              
645             This is mainly useful for decoding the value stored in the
646             C attribute.
647              
648             =cut
649              
650 0     0 1 0 sub routine { return $_[0]->{flags}{routine}; }
651              
652             =head2 attributes
653              
654             =for usage
655              
656             $obj->attributes;
657             PDL::Func->attributes;
658              
659             =for ref
660              
661             Print out the flags for the attributes of a PDL::Func object.
662              
663             Useful in case the documentation is just too opaque!
664              
665             =for example
666              
667             PDL::Func->attributes;
668             Flags Attribute
669             SGR x
670             SGR y
671             G err
672              
673             =cut
674              
675             # note, can be called with the class, rather than just
676             # an object. However, not of great use, as this will only
677             # ever return the values for Interpolate => Linear
678             #
679             # to allow this, I've used a horrible hack - we actually
680             # create an object and then print out the attributes from that
681             # Ugh!
682             #
683             # It would have been useful if I'd stuck to sub-classes
684             # for different schemes
685             #
686             sub attributes {
687 0     0 1 0 my $self = shift;
688              
689             # ugh
690 0 0       0 $self = $self->init unless ref($self);
691              
692 0         0 print "Flags Attribute\n";
693 0         0 while ( my ( $attr, $hashref ) = each %{$self->{attributes}} ) {
  0         0  
694 0         0 my $flag = "";
695 0 0       0 $flag .= "S" if $hashref->{settable};
696 0 0       0 $flag .= "G" if $hashref->{gettable};
697 0 0       0 $flag .= "R" if $hashref->{required};
698              
699 0         0 printf " %-3s %s\n", $flag, $attr;
700             }
701 0         0 return;
702             } # sub: attributes()
703              
704             ####################################################################
705              
706             =head2 interpolate
707              
708             =for usage
709              
710             my $yi = $obj->interpolate( $xi );
711              
712             =for ref
713              
714             Returns the interpolated function at a given set of points
715             (PDL::Func).
716              
717             A status value of -1, as returned by the C method,
718             means that some of the C<$xi> points lay outside the
719             range of the data. The values for these points
720             were calculated by extrapolation (the details depend on the
721             scheme being used).
722              
723             =cut
724              
725             sub interpolate {
726 6     6 1 32 my $self = shift;
727 6         11 my $xi = shift;
728              
729 6 50       19 croak 'Usage: $obj->interpolate( $xi )' . "\n"
730             unless defined $xi;
731              
732             # check everything is fine
733 6         24 $self->_check_attr();
734              
735             # get values in one go
736 6         21 my ( $x, $y ) = $self->_get_value( qw( x y ) );
737              
738             # farm off to routines
739 6         17 my $iflag = $self->scheme;
740 6 100 66     45 if ( $iflag eq "Linear" ) {
    50          
741 1         6 return _interp_linear( $self, $xi, $x, $y );
742             } elsif ( $iflag eq "Hermite" or $iflag eq "CSpline" ) {
743 5         18 return _interp_hermite( $self, $xi, $x, $y );
744             }
745              
746             } # sub: interpolate()
747              
748             sub _interp_linear {
749 1     1   3 my ( $self, $xi, $x, $y ) = ( @_ );
750              
751 1         172 my ( $yi, $err ) = PDL::Primitive::interpolate( $xi, $x, $y );
752              
753 1 50       11 $self->{flags}{status} = (any $err) ? -1 : 1;
754 1         16 $self->_set_value( err => $err );
755 1         3 $self->{flags}{routine} = "interpolate";
756              
757 1         7 return $yi;
758             } # sub: _interp_linear()
759              
760             sub _interp_hermite {
761 5     5   37 my ( $self, $xi, $x, $y ) = @_;
762             # get gradient
763 5         15 my $g = $self->_get_value( 'g' );
764 5         307 my ( $yi, $ierr ) = PDL::Primitive::pchip_chfe( $x, $y, $g, $xi );
765 5         32 $self->{flags}{routine} = "pchip_chfe";
766 5         19 $self->_set_value( err => $ierr );
767 5 50       22 if ( all $ierr == 0 ) {
    0          
768             # everything okay
769 5         14 $self->{flags}{status} = 1;
770             } elsif ( all $ierr > 0 ) {
771             # extrapolation was required
772 0         0 $self->{flags}{status} = -1;
773             } else {
774             # a problem
775 0         0 $self->{flags}{status} = 0;
776             }
777 5         68 return $yi;
778             } # sub: _interp_linear()
779              
780             =head2 gradient
781              
782             =for usage
783              
784             my $gi = $obj->gradient( $xi );
785             my ( $yi, $gi ) = $obj->gradient( $xi );
786              
787             =for ref
788              
789             Returns the derivative and, optionally,
790             the interpolated function for other than the C
791             scheme (PDL::Func).
792              
793             =cut
794              
795             sub gradient {
796 2     2 1 8 my $self = shift;
797 2         5 my $xi = shift;
798              
799 2 50       8 croak 'Usage: $obj->gradient( $xi )' . "\n"
800             unless defined $xi;
801              
802 2 100       7 croak 'Error: can not call gradient for Interpolate => "Linear".' ."\n"
803             if $self->scheme eq "Linear";
804              
805             # check everything is fine
806 1         5 $self->_check_attr();
807              
808             # get values in one go
809 1         5 my ( $x, $y, $g ) = $self->_get_value( qw( x y g ) );
810              
811 1         94 my ( $yi, $gi, $ierr ) = PDL::Primitive::pchip_chfd( $x, $y, $g, $xi );
812 1         9 $self->{flags}{routine} = "pchip_chfd";
813 1         6 $self->_set_value( err => $ierr );
814              
815 1 50       6 if ( all $ierr == 0 ) {
    0          
816             # everything okay
817 1         4 $self->{flags}{status} = 1;
818             } elsif ( all $ierr > 0 ) {
819             # extrapolation was required
820 0         0 $self->{flags}{status} = -1;
821             } else {
822             # a problem
823 0         0 $self->{flags}{status} = 0;
824             }
825              
826             # note order of values
827 1 50       16 return wantarray ? ( $yi, $gi ) : $gi;
828              
829             } # sub: gradient
830              
831             =head2 integrate
832              
833             =for usage
834              
835             my $ans = $obj->integrate( index => pdl( 2, 5 ) );
836             my $ans = $obj->integrate( x => pdl( 2.3, 4.5 ) );
837              
838             =for ref
839              
840             Integrate the function stored in the PDL::Func
841             object, if the scheme is C.
842              
843             The integration can either be between points of
844             the original C array (C), or arbitrary x values
845             (C). For both cases, a two element ndarray
846             should be given,
847             to specify the start and end points of the integration.
848              
849             =over 7
850              
851             =item index
852              
853             The values given refer to the indices of the points
854             in the C array.
855              
856             =item x
857              
858             The array contains the actual values to integrate between.
859              
860             =back
861              
862             If the C method returns a value of -1, then
863             one or both of the integration limits did not
864             lie inside the C array. I with the
865             result in such a case.
866              
867             =cut
868              
869             sub integrate {
870 0     0 1 0 my $self = shift;
871              
872 0 0       0 croak 'Usage: $obj->integrate( $type => $limits )' . "\n"
873             unless @_ == 2;
874              
875             croak 'Error: can not call integrate except for Interpolate => "Hermite".' ."\n"
876 0 0       0 unless $self->{flags}{scheme} eq "Hermite";
877              
878             # check everything is fine
879 0         0 $self->_check_attr();
880              
881 0         0 $self->{flags}{status} = 0;
882 0         0 $self->{flags}{routine} = "none";
883              
884 0         0 my ( $type, $indices ) = ( @_ );
885              
886 0 0 0     0 croak "Unknown type ($type) sent to integrate method.\n"
887             unless $type eq "x" or $type eq "index";
888              
889 0         0 my $fdim = $indices->getdim(0);
890 0 0       0 croak "Indices must have a first dimension of 2, not $fdim.\n"
891             unless $fdim == 2;
892              
893 0         0 my $lo = $indices->slice('(0)');
894 0         0 my $hi = $indices->slice('(1)');
895              
896 0         0 my ( $x, $y, $g ) = $self->_get_value( qw( x y g ) );
897 0         0 my ( $ans, $ierr );
898              
899 0 0       0 if ( $type eq "x" ) {
900 0         0 ( $ans, $ierr ) = PDL::Primitive::pchip_chia( $x, $y, $g, $lo, $hi );
901 0         0 $self->{flags}{routine} = "pchip_chia";
902              
903 0 0       0 if ( all $ierr == 0 ) {
    0          
904             # everything okay
905 0         0 $self->{flags}{status} = 1;
906             } elsif ( any $ierr < 0 ) {
907             # a problem
908 0         0 $self->{flags}{status} = 0;
909             } else {
910             # out of range
911 0         0 $self->{flags}->{status} = -1;
912             }
913              
914             } else {
915 0         0 ( $ans, $ierr ) = PDL::Primitive::pchip_chid( $x, $y, $g, $lo, $hi );
916 0         0 $self->{flags}->{routine} = "pchip_chid";
917              
918 0 0       0 if ( all $ierr == 0 ) {
    0          
919             # everything okay
920 0         0 $self->{flags}{status} = 1;
921             } elsif ( all $ierr != -4 ) {
922             # a problem
923 0         0 $self->{flags}{status} = 0;
924             } else {
925             # out of range (ierr == -4)
926 0         0 $self->{flags}{status} = -1;
927             }
928              
929             }
930              
931 0         0 $self->_set_value( err => $ierr );
932 0         0 return $ans;
933              
934             } # sub: integrate()
935              
936             ####################################################################
937              
938             =head2 pchip
939              
940             =for ref
941              
942             Convenience function to interpolate using C method. Exportable.
943              
944             =for usage
945              
946             use PDL::Func qw(pchip);
947             $yi = pchip($x, $y, $xi);
948              
949             =cut
950              
951             sub pchip {
952 1     1 1 4 my ($x, $y, $xi) = @_;
953 1         7 my $obj = PDL::Func->init( Interpolate => "Hermite", x => $x, y => $y );
954 1         6 my $yi = $obj->interpolate( $xi );
955 1 50       5 croak "interpolate gave an error: ", $obj->get( 'err' ) if $obj->status != 1;
956 1         27 $yi;
957             }
958              
959             =head2 spline
960              
961             =for ref
962              
963             Convenience function to interpolate using C method. Exportable.
964              
965             =for usage
966              
967             use PDL::Func qw(spline);
968             $yi = spline($x, $y, $xi);
969              
970             =cut
971              
972             sub spline {
973 1     1 1 5 my ($x, $y, $xi) = @_;
974 1         5 my $obj = PDL::Func->init( Interpolate => "CSpline", x => $x, y => $y );
975 1         18 my $yi = $obj->interpolate( $xi );
976 1 50       4 croak "interpolate gave an error: ", $obj->get( 'err' ) if $obj->status != 1;
977 1         20 $yi;
978             }
979              
980             =head1 TODO
981              
982             It should be relatively easy to provide an interface to other
983             interpolation routines, such as those provided by the
984             Gnu Scientific Library (GSL), or the B-spline routines
985             in the SLATEC library.
986              
987             In the documentation, the methods are preceded by C
988             to avoid clashes with functions such as C when using
989             the C or C commands within I.
990              
991             =head1 AUTHOR
992              
993             Copyright (C) 2000,2001 Doug Burke (dburke@cfa.harvard.edu).
994             All rights reserved. There is no warranty.
995             You are allowed to redistribute this software / documentation as
996             described in the file COPYING in the PDL distribution.
997              
998             Thanks to Robin Williams, Halldór Olafsson, and Vince McIntyre.
999              
1000             =cut
1001              
1002             ####################################################################
1003             # End with a true
1004             1;