← Back to branch summary

~ubuntu-branches/ubuntu/natty/libstatistics-basic-perl/natty

« back to all changes in this revision

Viewing changes to Basic/LeastSquareFit.pm

  • Committer: Bazaar Package Importer
  • Author(s): Ryan Niebur, Nathan Handler, Ryan Niebur
  • Date: 2009-07-01 20:22:06 UTC
  • mfrom: (1.2.1 upstream) (2.1.1 karmic)
  • Revision ID: james.westby@ubuntu.com-20090701202206-0co1izn0pj047x4i
Tags: 1.6600-1
[ Nathan Handler ]
* debian/watch: Update to ignore development releases.

[ Ryan Niebur ]
* New upstream release
* Debian Policy 3.8.2
* enable author tests

Show diffs side-by-side

added added

removed removed

Lines of Context:
Basic/LeastSquareFit.pm
5
5
use warnings;
6
6
use Carp;
7
7
 
8
 
use Statistics::Basic;
 
8
use base 'Statistics::Basic::_TwoVectorBase';
9
9
 
10
10
use overload
11
11
    '""' => sub {
12
 
        my ($alpha,$beta) = map{$Statistics::Basic::fmt->format_number($_, $ENV{IPRES})} $_[0]->query;
13
 
        "alpha: $alpha, beta: $beta";
 
12
        my ($alpha,$beta) = map{$Statistics::Basic::fmt->format_number($_, $Statistics::Basic::IPRES)} $_[0]->query;
 
13
        "LSF( alpha: $alpha, beta: $beta )";
14
14
    },
15
15
    '0+' => sub { croak "the result of LSF may not be used as a number" },
16
16
    fallback => 1; # tries to do what it would have done if this wasn't present.
17
17
 
18
 
1;
19
 
 
20
18
# new {{{
21
19
sub new {
22
20
    my $this = shift;
23
 
    my $v1   = eval { Statistics::Basic::Vector->new( shift ) }; croak $@ if $@;
24
 
    my $v2   = eval { Statistics::Basic::Vector->new( shift ) }; croak $@ if $@;
 
21
    my @var1  = (shift || ());
 
22
    my @var2  = (shift || ());
 
23
    my $v1    = eval { Statistics::Basic::Vector->new( @var1 ) } or croak $@;
 
24
    my $v2    = eval { Statistics::Basic::Vector->new( @var2 ) } or croak $@;
25
25
 
26
26
    $this = bless {}, $this;
27
27
 
28
 
    my $c = $v1->get_linked_computer( LSF => $v2 );
 
28
    my $c = $v1->_get_linked_computer( LSF => $v2 );
29
29
    return $c if $c;
30
30
 
31
 
    $this->{vrx} = new Statistics::Basic::Variance($v1);
32
 
    $this->{vry} = new Statistics::Basic::Variance($v2);
33
 
    $this->{mnx} = new Statistics::Basic::Mean($v1);
34
 
    $this->{mny} = new Statistics::Basic::Mean($v2);
35
 
    $this->{cov} = new Statistics::Basic::Covariance($v1, $v2);
36
 
 
37
 
    $v1->set_linked_computer( LSF => $this, $v2 );
38
 
    $v2->set_linked_computer( LSF => $this, $v1 );
 
31
    $this->{_vectors} = [ $v1, $v2 ];
 
32
 
 
33
    $this->{vrx} = eval { Statistics::Basic::Variance->new($v1)        } or croak $@;
 
34
    $this->{mnx} = eval { Statistics::Basic::Mean->new($v1)            } or croak $@;
 
35
    $this->{mny} = eval { Statistics::Basic::Mean->new($v2)            } or croak $@;
 
36
    $this->{cov} = eval { Statistics::Basic::Covariance->new($v1, $v2) } or croak $@;
 
37
 
 
38
    $v1->_set_linked_computer( LSF => $this, $v2 );
 
39
    $v2->_set_linked_computer( LSF => $this, $v1 );
39
40
 
40
41
    return $this;
41
42
}
42
43
# }}}
43
 
# recalc {{{
44
 
sub recalc {
 
44
# _recalc {{{
 
45
sub _recalc {
45
46
    my $this  = shift;
46
47
 
47
48
    delete $this->{recalc_needed};
48
49
    delete $this->{alpha};
49
50
    delete $this->{beta};
50
51
 
51
 
    unless( $this->{vrx}->query ) {
52
 
        unless( defined $this->{vrx}->query ) {
53
 
            warn "[recalc LSF] undef variance...\n" if $ENV{DEBUG};
54
 
 
55
 
        } else {
56
 
            warn "[recalc LSF] narrowly avoided division by zero.  Something is probably wrong.\n" if $ENV{DEBUG};
57
 
        }
58
 
 
59
 
        return;
60
 
    }
61
 
 
62
 
    $this->{beta}  = ($this->{cov}->query / $this->{vrx}->query);
63
 
    $this->{alpha} = ($this->{mny}->query - ($this->{beta} * $this->{mnx}->query));
64
 
 
65
 
    warn "[recalc LSF] (alpha: $this->{alpha}, beta: $this->{beta})\n" if $ENV{DEBUG};
66
 
}
67
 
# }}}
68
 
# recalc_needed {{{
69
 
sub recalc_needed {
70
 
    my $this = shift;
71
 
       $this->{recalc_needed} = 1;
72
 
 
73
 
    warn "[recalc_needed LSF]\n" if $ENV{DEBUG};
 
52
    my $vrx = $this->{vrx}->query; return unless defined $vrx; return unless $vrx > 0;
 
53
    my $mnx = $this->{mnx}->query; return unless defined $mnx; return unless $mnx > 0;
 
54
    my $mny = $this->{mny}->query; return unless defined $mny;
 
55
    my $cov = $this->{cov}->query; return unless defined $cov;
 
56
 
 
57
    $this->{beta}  = ($cov / $vrx);
 
58
    $this->{alpha} = ($mny - ($this->{beta} * $mnx));
 
59
 
 
60
    warn "[recalc " . ref($this) . "] (alpha: $this->{alpha}, beta: $this->{beta})\n" if $Statistics::Basic::DEBUG;
 
61
 
 
62
    return;
74
63
}
75
64
# }}}
76
65
# query {{{
77
66
sub query {
78
67
    my $this = shift;
79
68
 
80
 
    $this->recalc if $this->{recalc_needed};
 
69
    $this->_recalc if $this->{recalc_needed};
81
70
 
82
 
    warn "[query LSF ($this->{alpha}, $this->{beta})]\n" if $ENV{DEBUG};
 
71
    warn "[query " . ref($this) . " ($this->{alpha}, $this->{beta})]\n" if $Statistics::Basic::DEBUG;
83
72
 
84
73
    return (wantarray ? ($this->{alpha}, $this->{beta}) : [$this->{alpha}, $this->{beta}] );
85
74
}
86
75
# }}}
 
76
 
87
77
# query_vector1 {{{
88
78
sub query_vector1 {
89
79
    my $this = shift;
105
95
    return $this->{mnx};
106
96
}
107
97
# }}}
108
 
# query_mean2 {{{
109
 
sub query_mean2 {
110
 
    my $this = shift;
111
 
 
112
 
    return $this->{mny};
113
 
}
114
 
# }}}
115
98
# query_variance1 {{{
116
99
sub query_variance1 {
117
100
    my $this = shift;
119
102
    return $this->{vrx};
120
103
}
121
104
# }}}
122
 
# query_variance2 {{{
123
 
sub query_variance2 {
124
 
    my $this = shift;
125
 
 
126
 
    return $this->{vry};
127
 
}
128
 
# }}}
129
105
# query_covariance {{{
130
106
sub query_covariance {
131
107
    my $this = shift;
149
125
    my ($alpha, $beta) = $this->query;
150
126
    my $y = shift;
151
127
 
152
 
    my $x = eval { ( ($y-$alpha)/$beta ) }; croak $@ if $@;
 
128
    defined( my $x = eval { ( ($y-$alpha)/$beta ) }) or croak $@;
153
129
    return $x;
154
130
}
155
131
# }}}
156
132
 
157
 
# size {{{
158
 
sub size {
159
 
    my $this = shift;
160
 
 
161
 
    return $this->{cov}->size;
162
 
}
163
 
# }}}
164
 
# set_size {{{
165
 
sub set_size {
166
 
    my $this = shift;
167
 
    my $size = shift;
168
 
 
169
 
    eval { $this->{vrx}->set_size( $size );
170
 
           $this->{vry}->set_size( $size ); }; croak $@ if $@;
171
 
}
172
 
# }}}
173
 
# insert {{{
174
 
sub insert {
175
 
    my $this = shift;
176
 
 
177
 
    warn "[insert LSF]\n" if $ENV{DEBUG};
178
 
 
179
 
    croak "this insert() takes precisely two arguments.  They can be arrayrefs if you like." unless 2 == int @_;
180
 
 
181
 
    $this->{vrx}->insert( $_[0] );
182
 
    $this->{vry}->insert( $_[1] );
183
 
}
184
 
# }}}
185
 
# ginsert {{{
186
 
sub ginsert {
187
 
    my $this = shift;
188
 
 
189
 
    warn "[ginsert LSF]\n" if $ENV{DEBUG};
190
 
 
191
 
    croak "this ginsert() takes precisely two arguments.  They can be arrayrefs if you like." 
192
 
        unless 2 == int @_;
193
 
 
194
 
    $this->{vrx}->ginsert( $_[0] );
195
 
    $this->{vry}->ginsert( $_[1] );
196
 
 
197
 
    croak "The two vectors in a LeastSquareFit object must be the same length."
198
 
        unless $this->{vrx}->size == $this->{vry}->size;
199
 
}
200
 
# }}}
201
 
# set_vector {{{
202
 
sub set_vector {
203
 
    my $this = shift;
204
 
 
205
 
    warn "[set_vector LSF]\n" if $ENV{DEBUG};
206
 
 
207
 
    croak "this set_vector() takes precisely two arguments.  They can be arrayrefs if you like." 
208
 
        unless 2 == int @_;
209
 
 
210
 
    $this->{vrx}->set_vector( $_[0] );
211
 
    $this->{vry}->set_vector( $_[1] );
212
 
 
213
 
    croak "The two vectors in a LeastSquareFit object must be the same length."
214
 
        unless $this->{vrx}->size == $this->{vry}->size;
215
 
}
216
 
# }}}
 
133
1;