File Coverage

blib/lib/Math/Business/LaguerreFilter.pm
Criterion Covered Total %
statement 73 94 77.6
branch 29 42 69.0
condition 4 6 66.6
subroutine 11 15 73.3
pod 0 10 0.0
total 117 167 70.0


line stmt bran cond sub pod time code
1             package Math::Business::LaguerreFilter;
2              
3 2     2   6762 use strict;
  2         12  
  2         38  
4 2     2   6 use warnings;
  2         2  
  2         33  
5 2     2   6 use Carp;
  2         3  
  2         92  
6             use constant {
7 2         918 ALPHA => 2,
8             LENGTH => 3,
9             F => -2,
10             TAG => -1,
11 2     2   9 };
  2         2  
12              
13             1;
14              
15 0     0 0 0 sub tag { (shift)->[TAG] }
16              
17 0     0 0 0 sub recommended { croak "no recommendation" }
18              
19             sub dnew {
20 0     0 0 0 my $class = shift;
21 0 0       0 my $days = int shift; $days = 4 unless $days > 1;
  0         0  
22 0         0 my $this = $class->new(2/(1+$days));
23              
24 0         0 return $this;
25             }
26              
27             sub new {
28 4     4 0 586 my $class = shift;
29 4         12 my $this = bless [
30             [], # [0] P-hist
31             [], # [1] L0-L4
32             0, # [2] alpha
33             0, # [3] adaptive length
34             [], # [4] adaptive diff history
35             undef, # [5] filter
36             undef, # [6] tag
37             ], $class;
38              
39 4         7 my $alpha = shift;
40 4 100       9 $alpha = 0.5 if not defined $alpha;
41 4         12 $this->set_alpha( $alpha );
42              
43 4         4 my $length = shift;
44 4 100       9 if( defined $length ) {
45 1         8 $this->set_adaptive( $length );
46             }
47              
48 4         9 return $this;
49             }
50              
51             sub reset {
52 6     6 0 6 my $this = shift;
53 6         9 $this->[0] = [];
54 6         8 $this->[1] = [];
55 6         9 $this->[4] = [];
56             return
57 6         8 }
58              
59             sub set_days {
60 0     0 0 0 my $this = shift;
61 0         0 my $arg = 0+shift;
62              
63 0         0 my $alpha = 2/(1+$arg);
64 0         0 eval { $this->set_alpha( $alpha ) };
  0         0  
65 0 0       0 croak "set_days() is basically set_alpha(2/(1+$arg)), which complained: $@" if $@;
66              
67 0         0 $this->[TAG] = "LAG($arg)";
68 0         0 $this->reset
69             }
70              
71             sub set_alpha {
72 4     4 0 4 my $this = shift;
73 4         10 my $alpha = 0+shift;
74              
75 4 50 33     24 croak "alpha must be a real between >=0 and <=1" unless $alpha >= 0 and $alpha <= 1;
76 4         13 my $arg = int ( (1/$alpha)*2-1 ); # pretty sure... gah, algebra
77              
78 4         14 $this->[TAG] = "LAG($arg)";
79 4         12 $this->reset
80             }
81              
82             sub set_adaptive {
83 2     2 0 5 my $this = shift;
84 2         10 my $that = int shift;
85              
86 2 50       7 croak "adaptive length must be an non-negative integer" unless $that >= 0;
87 2         3 $this->[LENGTH] = $that;
88 2         6 $this->reset
89             }
90              
91             sub insert {
92 7002     7002 0 270786 my $this = shift;
93 7002         10116 my ($h, $L, $alpha, $length, $diff, $filter) = @$this;
94              
95 7002 50       10579 croak "You must set the number of days before you try to insert" if not defined $alpha;
96 2     2   10 no warnings 'uninitialized';
  2         3  
  2         695  
97              
98 7002         9878 while( defined( my $P = shift ) ) {
99 7002 50       9080 if( ref $P ) {
100 0 0       0 my @a = eval {@$P}; croak $@ if $@;
  0         0  
  0         0  
101 0         0 my $c = 0+@a;
102 0 0       0 croak "high+low should only be two elements, not c=$c" unless $c == 2;
103 0         0 $P = ($a[0]+$a[1])/$c;
104             }
105              
106 7002 100       9456 if( defined $L->[0] ) {
107             # adapt alpha {{{
108 7000 100 100     12664 if( $length and defined($filter) ) {
109 3497         5359 my $d = abs($P-$filter);
110 3497         4198 push @$diff, $d;
111              
112 3497         3448 my $k = @$diff - $length;
113 3497 100       5158 splice @$diff, 0, $k if $k>0;
114              
115 3497 100       4895 if( $k > 0 ) { # NOTE Ehler really does this, "CurrentBar > Length". See below.
116             # IE, $k will only by >0 when we've moved past the 20th point
117 3477         3346 my $HH = $d;
118 3477         3042 my $LL = $d;
119              
120 3477         4419 for(@$diff) {
121 69540 100       77246 $HH = $_ if $_ > $HH;
122 69540 100       83344 $LL = $_ if $_ < $LL;
123             }
124              
125 3477 50       4146 if( $HH != $LL ) {
126             # Ehler: If CurrentBar > Length and HH - LL <> 0 then alpha = Median(((Diff - LL) / (HH - LL)), 5);
127              
128             # NOTE: wtf is a "5 bar median"? I guess it's this, or
129             # pretty close to it. I imagine Median() runs through
130             # the [] hist for Diff, LL, and HH, but I can't say for
131             # sure without access to the programming language he
132             # uses in the book.
133              
134             # AVG # my $sum = ($diff->[-5]-$LL)/($HH-$LL);
135             # AVG # $sum += ($diff->[$_]-$LL)/($HH-$LL) for (-4 .. -1);
136              
137             # AVG # ($this->[ALPHA] = $alpha = $sum / 5);
138              
139             # NOTE (later): he appears to mean the median (not
140             # average) of a scalar $HH/$LL against the last 5 @diff
141              
142 3477         4704 my @b5 = sort {$a<=>$b}map {(($diff->[$_]-$LL)/($HH-$LL))} -5 .. -1;
  25908         28377  
  17385         24821  
143              
144 3477         5464 $this->[ALPHA] = $alpha = $b5[2];
145             }
146             }
147             }
148             # }}}
149              
150 7000         9980 my $O = [ @$L ];
151              
152             # L0 = alpha*Price + (1 - alpha)*L0[1] = alpha*P + (1-alpha)*O[0]
153              
154 7000         10029 $L->[0] = $alpha*$P + (1-$alpha)*$O->[0];
155              
156             # L1 = (1 - alpha)*L1[1] - (1 - alpha)*L0 + L0[1] = (1 - alpha)*O[1] - (1 - alpha)*L[0] + O[0]
157             # L2 = (1 - alpha)*L2[1] - (1 - alpha)*L1 + L1[1] = (1 - alpha)*O[2] - (1 - alpha)*L[1] + O[1]
158             # L3 = (1 - alpha)*L3[1] - (1 - alpha)*L2 + L2[1] = (1 - alpha)*O[3] - (1 - alpha)*L[2] + O[2]
159              
160 7000 100       10416 $L->[1] = defined($O->[1]) ? (1 - $alpha)*$O->[1] - (1 - $alpha)*$L->[0] + $O->[0] : $O->[0];
161 7000 100       9467 $L->[2] = defined($O->[2]) ? (1 - $alpha)*$O->[2] - (1 - $alpha)*$L->[1] + $O->[1] : $O->[1];
162 7000 100       15293 $L->[3] = defined($O->[3]) ? (1 - $alpha)*$O->[3] - (1 - $alpha)*$L->[2] + $O->[2] : $O->[2];
163              
164             } else {
165 2         7 $L->[0] = $P;
166             }
167             }
168              
169 7002 100       8342 if( 4 == grep {defined $_} @$L ) {
  28002         36774  
170 6996         12961 $this->[F] = ($L->[0] + 2*$L->[1] + 2*$L->[2] + $L->[3])/6;
171             }
172             }
173              
174             sub query {
175 7002     7002 0 13819 my $this = shift;
176              
177 7002         8764 return $this->[F];
178             }
179              
180             __END__