← Back to branch summary

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

« back to all changes in this revision

Viewing changes to Basic/Covariance.pm

  • Committer: Bazaar Package Importer
  • Author(s): Ryan Niebur
  • Date: 2009-05-02 08:28:50 UTC
  • Revision ID: james.westby@ubuntu.com-20090502082850-nnj0uyxfv62xhtn4
Tags: upstream-1.6007
Import upstream version 1.6007

Show diffs side-by-side

added added

removed removed

Lines of Context:
Basic/Covariance.pm
 
1
 
 
2
package Statistics::Basic::Covariance;
 
3
 
 
4
use strict;
 
5
use warnings;
 
6
use Carp;
 
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;
 
18
 
 
19
# new {{{
 
20
sub new {
 
21
    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 $@;
 
24
 
 
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
    }
 
29
 
 
30
    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 );
 
38
 
 
39
    return $this;
 
40
}
 
41
# }}}
 
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;
 
52
 
 
53
    my $cardinality = $c1;
 
54
       $cardinality -- if $ENV{UNBIAS};
 
55
 
 
56
    delete $this->{recalc_necessary};
 
57
    delete $this->{covariance};
 
58
    return unless $cardinality > 0;
 
59
 
 
60
    my $v1 = $this->{v1}->query;
 
61
    my $v2 = $this->{v2}->query;
 
62
 
 
63
    my $m1 = $this->{m1}->query;
 
64
    my $m2 = $this->{m2}->query;
 
65
 
 
66
    if( $ENV{DEBUG} >= 2 ) {
 
67
        for my $i (0 .. $#$v1) {
 
68
            warn "[recalc covariance] ( $v1->[$i] - $m1 ) * ( $v2->[$i] - $m2 )\n";
 
69
        }
 
70
    }
 
71
 
 
72
    for my $i (0 .. $#$v1) {
 
73
        $sum += ( $v1->[$i] - $m1 ) * ( $v2->[$i] - $m2 );
 
74
    }
 
75
 
 
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
# }}}
 
100
# query_vector1 {{{
 
101
sub query_vector1 {
 
102
    my $this = shift;
 
103
 
 
104
    return $this->{v1};
 
105
}
 
106
# }}}
 
107
# query_vector2 {{{
 
108
sub query_vector2 {
 
109
    my $this = shift;
 
110
 
 
111
    return $this->{v2};
 
112
}
 
113
# }}}
 
114
# query_mean1 {{{
 
115
sub query_mean1 {
 
116
    my $this = shift;
 
117
 
 
118
    return $this->{m1};
 
119
}
 
120
# }}}
 
121
# query_mean2 {{{
 
122
sub query_mean2 {
 
123
    my $this = shift;
 
124
 
 
125
    return $this->{m2};
 
126
}
 
127
# }}}
 
128
 
 
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
# }}}