File Coverage

blib/lib/Math/Business/LaguerreFilter.pm

Criterion	Covered	Total	%
statement	66	87	75.8
branch	27	42	64.2
condition	4	6	66.6
subroutine	10	14	71.4
pod	0	9	0.0
total	107	158	67.7

package Math::Business::LaguerreFilter;

use strict;
use warnings;
use Carp;
use constant {
    ALPHA  =>  2,
    LENGTH =>  3,
    F      => -2,
    TAG    => -1,
};

1;

sub tag { (shift)->[TAG] }

sub recommended { croak "no recommendation" }

sub dnew {
    my $class = shift;
    my $days  = int shift; $days = 4 unless $days > 1;
    my $this  = $class->new(2/(1+$days));

    return $this;
}

sub new {
    my $class = shift;
    my $this  = bless [], $class;

    my $alpha = shift;
    if( defined $alpha ) {
        $this->set_alpha( $alpha );
    }

    my $length = shift;
    if( defined $length ) {
        $this->set_adaptive( $length );
    }

    return $this;
}

sub set_days {
    my $this = shift;
    my $arg  = 0+shift;

    my $alpha = 2/(1+$arg);
    eval { $this->set_alpha( $alpha ) };
    croak "set_days() is basically set_alpha(2/(1+$arg)), which complained: $@" if $@;

    $this->{tag} = "LAG($arg)";
}

sub set_alpha {
    my $this  = shift;
    my $alpha = 0+shift;

    croak "alpha must be a real between >=0 and <=1" unless $alpha >= 0 and $alpha <= 1;
    @$this = (
        [],    # P-hist
        [],    # L0-L4
        $alpha,
        0,     # adaptive length
        [],    # adaptive diff history
        undef, # filter
        undef, # tag
    );

    my $arg = int ( (1/$alpha)*2-1 ); # pretty sure... gah, algebra
    $this->[TAG] = "LAG($arg)";
}

sub set_adaptive {
    my $this = shift;
    my $that = int shift;

    croak "adaptive length must be an non-negative integer" unless $that >= 0;
    $this->[LENGTH] = $that;
}

sub insert {
    my $this = shift;
    my ($h, $L, $alpha, $length, $diff, $filter) = @$this;

    croak "You must set the number of days before you try to insert" if not defined $alpha;
    no warnings 'uninitialized';

    while( defined( my $P = shift ) ) {
        if( ref $P ) {
            my @a = eval {@$P}; croak $@ if $@;
            my $c = 0+@a;
            croak "high+low should only be two elements, not c=$c" unless $c == 2;
            $P = ($a[0]+$a[1])/$c;
        }

        if( defined $L->[0] ) {
            # adapt alpha {{{
            if( $length and defined($filter) ) {
                my $d = abs($P-$filter);
                push @$diff, $d;

                my $k = @$diff - $length;
                splice @$diff, 0, $k if $k>0;

                if( $k > 0 ) {   # NOTE Ehler really does this, "CurrentBar > Length".  See below.
                                 # IE, $k will only by >0 when we've moved past the 20th point
                    my $HH = $d;
                    my $LL = $d;

                    for(@$diff) {
                        $HH = $_ if $_ > $HH;
                        $LL = $_ if $_ < $LL;
                    }

                    if( $HH != $LL ) {
                        # Ehler: If CurrentBar > Length and HH - LL <> 0 then alpha = Median(((Diff - LL) / (HH - LL)), 5);

                        # NOTE: wtf is a "5 bar median"?  I guess it's this, or
                        # pretty close to it.  I imagine Median() runs through
                        # the [] hist for Diff, LL, and HH, but I can't say for
                        # sure without access to the programming language he
                        # uses in the book.

                        # AVG # my $sum  = ($diff->[-5]-$LL)/($HH-$LL);
                        # AVG #    $sum += ($diff->[$_]-$LL)/($HH-$LL) for (-4 .. -1);

                        # AVG # ($this->[ALPHA] = $alpha = $sum / 5);

                        # NOTE (later): he appears to mean the median (not
                        # average) of a scalar $HH/$LL against the last 5 @diff

                        my @b5 = sort {$a<=>$b}map {(($diff->[$_]-$LL)/($HH-$LL))} -5 .. -1;

                        $this->[ALPHA] = $alpha = $b5[2];
                    }
                }
            }
            # }}}

            my $O = [ @$L ];

            # L0 = alpha*Price + (1 - alpha)*L0[1] = alpha*P + (1-alpha)*O[0]

            $L->[0] = $alpha*$P + (1-$alpha)*$O->[0];

            # L1 = (1 - alpha)*L1[1] - (1 - alpha)*L0 + L0[1] = (1 - alpha)*O[1] - (1 - alpha)*L[0] + O[0]
            # L2 = (1 - alpha)*L2[1] - (1 - alpha)*L1 + L1[1] = (1 - alpha)*O[2] - (1 - alpha)*L[1] + O[1]
            # L3 = (1 - alpha)*L3[1] - (1 - alpha)*L2 + L2[1] = (1 - alpha)*O[3] - (1 - alpha)*L[2] + O[2]

            $L->[1] = defined($O->[1]) ? (1 - $alpha)*$O->[1] - (1 - $alpha)*$L->[0] + $O->[0] : $O->[0];
            $L->[2] = defined($O->[2]) ? (1 - $alpha)*$O->[2] - (1 - $alpha)*$L->[1] + $O->[1] : $O->[1];
            $L->[3] = defined($O->[3]) ? (1 - $alpha)*$O->[3] - (1 - $alpha)*$L->[2] + $O->[2] : $O->[2];

        } else {
            $L->[0] = $P;
        }
    }

    if( 4 == grep {defined $_} @$L ) {
        $this->[F] = ($L->[0] + 2*$L->[1] + 2*$L->[2] + $L->[3])/6;
    }
}

sub query {
    my $this = shift;

    return $this->[F];
}

__END__