File Coverage

blib/lib/Math/Business/SM/Stochastic.pm

Criterion	Covered	Total	%
statement	163	202	80.6
branch	32	56	57.1
condition	38	68	55.8
subroutine	22	25	88.0
pod	0	17	0.0
total	255	368	69.2

package Math::Business::SM::Stochastic;

use strict;
use warnings;
use Carp;

use Math::Business::SMA;

1;

sub tag { (shift)->{tag} }

use constant METHOD_LANE => 0;
use constant METHOD_FAST => 1;
use constant METHOD_SLOW => 2;
use constant METHOD_FULL => 3;

sub recommended { my $class = shift; return $class->new(METHOD_LANE,5,3); }

sub method_slow { my $class = shift; return $class->new(METHOD_SLOW,$_[0]||14,$_[1]||3); }
sub method_fast { my $class = shift; return $class->new(METHOD_FAST,$_[0]||14,$_[1]||3); }
sub method_full { my $class = shift; return $class->new(METHOD_FULL,$_[0]||14,$_[1]||3,$_[2]||3); }

sub new {
    my $class = shift;
    my $meth  = shift || METHOD_LANE;
    my $kp    = shift || 5;
    my $dp    = shift || 3;
    my $xp    = shift || 3;

    my $this  = bless {}, $class;

    $this->set_method( $meth );
    $this->set_days( $kp );
    $this->set_dperiod( $dp );
    $this->set_xperiod( $xp );

    return $this;
}

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

    croak "days must be a positive non-zero integer" if $arg <= 0;

    $this->{kp} = $arg;
    $this->set_tag;
}

sub set_dperiod {
    my $this = shift;
    my $arg = shift;

    croak "days must be a positive non-zero integer" if $arg <= 0;

    $this->{dp} = $arg;
    $this->set_tag;
}

sub set_xperiod {
    my $this = shift;
    my $arg = shift;

    croak "days must be a positive non-zero integer" if $arg <= 0;

    $this->{xp} = $arg;
    $this->set_tag;
}

sub set_method {
    my $this = shift;
    my $meth = shift;

    croak "method not known" unless grep {$meth == $_} (METHOD_LANE, METHOD_FAST, METHOD_SLOW, METHOD_FULL);

    $this->{m} = $meth;

    delete $this->{ksma};
    delete $this->{dsma};

    $this->set_tag;

    return;
}

sub set_tag {
    my $this = shift;

    return if grep { not defined } @$this{qw(kp dp xp)};

    if( $this->{m} == METHOD_FULL ) {
        $this->{tag} = "FullSTO($this->{kp},$this->{dp},$this->{xp})";

    } elsif( $this->{m} == METHOD_FAST ) {
        $this->{tag} = "FSTO($this->{kp},$this->{dp})";

    } elsif( $this->{m} == METHOD_SLOW ) {
        $this->{tag} = "SSTO($this->{kp},$this->{dp})";

    } else {
        $this->{tag} = "STO($this->{kp},$this->{dp})";
    }
}

{
    my $method = {
        METHOD_LANE() => \&insert_lane,
        METHOD_FAST() => \&insert_fast,
        METHOD_SLOW() => \&insert_slow,
        METHOD_FULL() => \&insert_full,
    };

    sub insert {
        my $this = shift;
        my $m = $method->{$this->{m}};

        return $this->$m( @_ );
    }
}

# {{{ sub insert_lane
sub insert_lane {
    my $this = shift;

    my $l = ($this->{low_hist}  ||= []);
    my $h = ($this->{high_hist} ||= []);
    my $kp = $this->{kp};
    my $dp = $this->{dp};

    my ($K, $D);
    while( defined( my $point = shift ) ) {
        croak "insert takes three tuple (high, low, close)" unless ref $point eq "ARRAY" and @$point == 3;
        my ($t_high, $t_low, $t_close) = @$point;

        push @$l, $t_low;  shift @$l while @$l > $kp;
        push @$h, $t_high; shift @$h while @$h > $kp;

        if( @$l == $kp ) {
            my $L = $l->[0]; for( 1 .. $#$l ) { $L = $l->[$_] if $l->[$_] < $L };
            my $H = $h->[0]; for( 1 .. $#$h ) { $H = $h->[$_] if $h->[$_] > $H };

            if( $H != $L ) {
                $K = 100 * ($t_close - $L)/($H-$L);
            } else {
                # added 2018-06-10 per Marcel Ebbrecht, to avoid division by
                # zero we don't really have any notes from Lane on this, so
                # K=100 seems reasonable; but I admit I have no idea what the
                # the "correct" behavior might be, if there is one.
                $K = 100;
            }

            $L = $l->[-$dp]; for( (-$dp+1) .. -1 ) { $L = $l->[$_] if $l->[$_] < $L };
            $H = $h->[-$dp]; for( (-$dp+1) .. -1 ) { $H = $h->[$_] if $h->[$_] > $H };

            if( $L != 0 ) {
                $D = 100 * $H / $L;
            } else {
                # also added 2018-06-10 (see above comment)
                $D = 100;
            }
        }
    }

    $this->{K} = $K;
    $this->{D} = $D;

    return;
}

# }}}
# {{{ sub insert_fast
sub insert_fast {
    my $this = shift;

    my $l = ($this->{low_hist}  ||= []);
    my $h = ($this->{high_hist} ||= []);
    my $kp = $this->{kp};
    my $dp = $this->{dp};

    my $dsma = ($this->{dsma} ||= Math::Business::SMA->new($dp));

    my ($K, $D);
    while( defined( my $point = shift ) ) {
        croak "insert takes three tuple (high, low, close)" unless ref $point eq "ARRAY" and @$point == 3;
        my ($t_high, $t_low, $t_close) = @$point;

        push @$l, $t_low;  shift @$l while @$l > $kp;
        push @$h, $t_high; shift @$h while @$h > $kp;

        if( @$l == $kp ) {
            my $L = $l->[0]; for( 1 .. $#$l ) { $L = $l->[$_] if $l->[$_] < $L };
            my $H = $h->[0]; for( 1 .. $#$h ) { $H = $h->[$_] if $h->[$_] > $H };

            $K = 100 * ($t_close - $L)/($H-$L);

            $dsma->insert($K);
            $D = $dsma->query;
        }
    }

    $this->{K} = $K;
    $this->{D} = $D;

    return;
}

# }}}
# {{{ sub insert_slow
sub insert_slow {
    my $this = shift;

    my $l = ($this->{low_hist}  ||= []);
    my $h = ($this->{high_hist} ||= []);
    my $kp = $this->{kp};
    my $dp = $this->{dp};

    my $dsma = ($this->{dsma} ||= Math::Business::SMA->new($dp));
    my $ksma = ($this->{ksma} ||= Math::Business::SMA->new($dp));

    my ($K, $D);
    while( defined( my $point = shift ) ) {
        croak "insert takes three tuple (high, low, close)" unless ref $point eq "ARRAY" and @$point == 3;
        my ($t_high, $t_low, $t_close) = @$point;

        push @$l, $t_low;  shift @$l while @$l > $kp;
        push @$h, $t_high; shift @$h while @$h > $kp;

        if( @$l == $kp ) {
            my $L = $l->[0]; for( 1 .. $#$l ) { $L = $l->[$_] if $l->[$_] < $L };
            my $H = $h->[0]; for( 1 .. $#$h ) { $H = $h->[$_] if $h->[$_] > $H };

            $ksma->insert( 100 * ($t_close - $L)/($H-$L) );
            $K = $ksma->query;

            $dsma->insert($K);
            $D = $dsma->query;
        }
    }

    $this->{K} = $K;
    $this->{D} = $D;

    return;
}

# }}}
# {{{ sub insert_full
sub insert_full {
    my $this = shift;

    my $l = ($this->{low_hist}  ||= []);
    my $h = ($this->{high_hist} ||= []);
    my $kp = $this->{kp};
    my $dp = $this->{dp};
    my $xp = $this->{xp} || $this->{dp};

    my $dsma = ($this->{dsma} ||= Math::Business::SMA->new($xp));
    my $ksma = ($this->{ksma} ||= Math::Business::SMA->new($xp));

    my ($K, $D);
    while( defined( my $point = shift ) ) {
        croak "insert takes three tuple (high, low, close)" unless ref $point eq "ARRAY" and @$point == 3;
        my ($t_high, $t_low, $t_close) = @$point;

        push @$l, $t_low;  shift @$l while @$l > $kp;
        push @$h, $t_high; shift @$h while @$h > $kp;

        if( @$l == $kp ) {
            my $L = $l->[0]; for( 1 .. $#$l ) { $L = $l->[$_] if $l->[$_] < $L };
            my $H = $h->[0]; for( 1 .. $#$h ) { $H = $h->[$_] if $h->[$_] > $H };

            $ksma->insert( 100 * ($t_close - $L)/($H-$L) );
            $K = $ksma->query;

            $dsma->insert($K);
            $D = $dsma->query;
        }
    }

    $this->{K} = $K;
    $this->{D} = $D;

    return;
}

# }}}

sub query {
    my $this = shift;

    return ($this->{D}, $this->{K});
}

__END__