← Back to branch summary

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

« back to all changes in this revision

Viewing changes to Basic/Covariance.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/Covariance.pm
5
5
use warnings;
6
6
use Carp;
7
7
 
8
 
use Statistics::Basic;
9
 
 
10
 
use overload
11
 
    '""' => sub { my $v = $_[0]->query; $Statistics::Basic::fmt->format_number("$v", $ENV{IPRES}) },
12
 
    '0+' => sub { $_[0]->query },
13
 
    ( exists($ENV{TOLER}) ?  ('==' => sub { abs($_[0]-$_[1])<=$ENV{TOLER} }) : () ),
14
 
    'eq' => sub { "$_[0]" eq "$_[1]" },
15
 
    fallback => 1; # tries to do what it would have done if this wasn't present.
16
 
 
17
 
1;
 
8
use base 'Statistics::Basic::_TwoVectorBase';
18
9
 
19
10
# new {{{
20
11
sub new {
21
12
    my $class = shift;
22
 
    my $v1    = eval { Statistics::Basic::Vector->new( $_[0] ) }; croak $@ if $@;
23
 
    my $v2    = eval { Statistics::Basic::Vector->new( $_[1] ) }; croak $@ if $@;
 
13
    my @var1  = (shift || ());
 
14
    my @var2  = (shift || ());
 
15
    my $v1    = eval { Statistics::Basic::Vector->new( @var1 ) } or croak $@;
 
16
    my $v2    = eval { Statistics::Basic::Vector->new( @var2 ) } or croak $@;
24
17
 
25
 
    if( my $c = $v1->get_linked_computer( covariance => $v2 ) ) {
26
 
        warn "[linked covariance v1:$v1 v2:$v2]\n" if $ENV{DEBUG} >= 2;
27
 
        return $c;
28
 
    }
 
18
    my $c = $v1->_get_linked_computer( covariance => $v2 );
 
19
    return $c if $c;
29
20
 
30
21
    my $this = bless {v1=>$v1, v2=>$v2}, $class;
31
 
    warn "[new covariance v1:$this->{v1} v2:$this->{v2}]\n" if $ENV{DEBUG} >= 2;
32
 
 
33
 
    $this->{m1} = eval { Statistics::Basic::Mean->new($v1) }; croak $@ if $@;
34
 
    $this->{m2} = eval { Statistics::Basic::Mean->new($v2) }; croak $@ if $@;
35
 
 
36
 
    $v1->set_linked_computer( covariance => $this, $v2 );
37
 
    $v2->set_linked_computer( covariance => $this, $v1 );
 
22
    warn "[new " . ref($this) . " v1:$this->{v1} v2:$this->{v2}]\n" if $Statistics::Basic::DEBUG >= 2;
 
23
 
 
24
    $this->{_vectors} = [ $v1, $v2 ];
 
25
 
 
26
    $this->{m1} = eval { Statistics::Basic::Mean->new($v1) } or croak $@;
 
27
    $this->{m2} = eval { Statistics::Basic::Mean->new($v2) } or croak $@;
 
28
 
 
29
    $v1->_set_linked_computer( covariance => $this, $v2 );
 
30
    $v2->_set_linked_computer( covariance => $this, $v1 );
38
31
 
39
32
    return $this;
40
33
}
41
34
# }}}
42
 
# recalc {{{
43
 
sub recalc {
44
 
    my $this  = shift;
45
 
    my $sum   = 0;
46
 
    my $c1    = $this->{v1}->size;
47
 
    my $c2    = $this->{v2}->size;
48
 
 
49
 
    warn "[recalc covariance] (\$c1, \$c2) = ($c1, $c2)\n" if $ENV{DEBUG};
50
 
 
51
 
    confess "the two vectors in a Covariance object must be the same length ($c2!=$c1)" unless $c2 == $c1;
 
35
# _recalc {{{
 
36
sub _recalc {
 
37
    my $this = shift;
 
38
    my $sum  = 0;
 
39
    my $v1   = $this->{v1};
 
40
    my $v2   = $this->{v2};
 
41
    my $c1   = $v1->query_size;
 
42
    my $c2   = $v2->query_size;
 
43
 
 
44
    warn "[recalc " . ref($this) . "] (\$c1, \$c2) = ($c1, $c2)\n" if $Statistics::Basic::DEBUG;
 
45
 
 
46
    confess "the two vectors in a " . ref($this) . " object must be the same length ($c2!=$c1)" unless $c2 == $c1;
52
47
 
53
48
    my $cardinality = $c1;
54
 
       $cardinality -- if $ENV{UNBIAS};
 
49
       $cardinality -- if $Statistics::Basic::UNBIAS;
55
50
 
56
51
    delete $this->{recalc_necessary};
57
 
    delete $this->{covariance};
 
52
    delete $this->{_value};
58
53
    return unless $cardinality > 0;
 
54
    return unless $v1->query_filled;
 
55
    return unless $v2->query_filled;
59
56
 
60
 
    my $v1 = $this->{v1}->query;
61
 
    my $v2 = $this->{v2}->query;
 
57
    $v1 = $v1->query;
 
58
    $v2 = $v2->query;
62
59
 
63
60
    my $m1 = $this->{m1}->query;
64
61
    my $m2 = $this->{m2}->query;
65
62
 
66
 
    if( $ENV{DEBUG} >= 2 ) {
 
63
    if( $Statistics::Basic::DEBUG >= 2 ) {
67
64
        for my $i (0 .. $#$v1) {
68
 
            warn "[recalc covariance] ( $v1->[$i] - $m1 ) * ( $v2->[$i] - $m2 )\n";
 
65
            warn "[recalc " . ref($this) . "] ( $v1->[$i] - $m1 ) * ( $v2->[$i] - $m2 )\n";
69
66
        }
70
67
    }
71
68
 
72
69
    for my $i (0 .. $#$v1) {
 
70
        no warnings 'uninitialized'; ## no critic
73
71
        $sum += ( $v1->[$i] - $m1 ) * ( $v2->[$i] - $m2 );
74
72
    }
75
73
 
76
 
    $this->{covariance} = ($sum / $cardinality);
77
 
 
78
 
    warn "[recalc covariance] ($sum/$cardinality) = $this->{covariance}\n" if $ENV{DEBUG};
79
 
}
80
 
# }}}
81
 
# recalc_needed {{{
82
 
sub recalc_needed {
83
 
    my $this = shift;
84
 
       $this->{recalc_needed} = 1;
85
 
 
86
 
    warn "[recalc_needed covariance]\n" if $ENV{DEBUG};
87
 
}
88
 
# }}}
89
 
# query {{{
90
 
sub query {
91
 
    my $this = shift;
92
 
 
93
 
    $this->recalc if $this->{recalc_needed};
94
 
 
95
 
    warn "[query covariance $this->{covariance}]\n" if $ENV{DEBUG};
96
 
 
97
 
    return $this->{covariance};
98
 
}
99
 
# }}}
 
74
    $this->{_value} = ($sum / $cardinality);
 
75
 
 
76
    warn "[recalc " . ref($this) . "] ($sum/$cardinality) = $this->{_value}\n" if $Statistics::Basic::DEBUG;
 
77
 
 
78
    return;
 
79
}
 
80
# }}}
 
81
 
100
82
# query_vector1 {{{
101
83
sub query_vector1 {
102
84
    my $this = shift;
126
108
}
127
109
# }}}
128
110
 
129
 
# size {{{
130
 
sub size {
131
 
    my $this = shift;
132
 
 
133
 
    return ($this->{v2}->size, $this->{v1}->size); # only v1->size is returned in scalar context
134
 
}
135
 
# }}}
136
 
# set_size {{{
137
 
sub set_size {
138
 
    my $this = shift;
139
 
    my $size = shift;
140
 
 
141
 
    eval { $this->{v1}->set_size( $size );
142
 
           $this->{v2}->set_size( $size ); }; croak $@ if $@;
143
 
}
144
 
# }}}
145
 
# insert {{{
146
 
sub insert {
147
 
    my $this = shift;
148
 
 
149
 
    warn "[insert covariance]\n" if $ENV{DEBUG};
150
 
 
151
 
    croak "this insert() takes precisely two arguments.  They can be arrayrefs if you like." unless 2 == int @_;
152
 
 
153
 
    $this->{v1}->insert( $_[0] );
154
 
    $this->{v2}->insert( $_[1] );
155
 
}
156
 
# }}}
157
 
# ginsert {{{
158
 
sub ginsert {
159
 
    my $this = shift;
160
 
 
161
 
    warn "[ginsert covariance]\n" if $ENV{DEBUG};
162
 
 
163
 
    croak "this ginsert() takes precisely two arguments.  They can be arrayrefs if you like." 
164
 
        unless 2 == int @_;
165
 
 
166
 
    my ($v1, $v2) = (@$this{'v1', 'v2'});
167
 
 
168
 
    $v1->ginsert( $_[0] );
169
 
    $v2->ginsert( $_[1] );
170
 
 
171
 
    if( ref $_[0] ) {
172
 
        my $c1 = $v1->size;
173
 
        my $c2 = $v2->size;
174
 
 
175
 
        croak "The two vectors in a Covariance object must be the same length ($c1!=$c2)."
176
 
            unless $c1 == $c2;
177
 
    }
178
 
}
179
 
# }}}
180
 
# set_vector {{{
181
 
sub set_vector {
182
 
    my $this = shift;
183
 
 
184
 
    warn "[set_vector covariance]\n" if $ENV{DEBUG};
185
 
 
186
 
    croak "this set_vector() takes precisely two arguments.  They can be arrayrefs if you like." 
187
 
        unless 2 == int @_;
188
 
 
189
 
    my ($v1, $v2) = (@$this{'v1', 'v2'});
190
 
 
191
 
    $v1->set_vector( $_[0] );
192
 
    $v2->set_vector( $_[1] );
193
 
 
194
 
    my $c1 = $v1->size;
195
 
    my $c2 = $v2->size;
196
 
 
197
 
    confess "The two vectors in a Covariance object must be the same length ($c1!=$c2)."
198
 
        unless $c1 == $c2;
199
 
}
200
 
# }}}
 
111
1;