File Coverage

blib/lib/Statistics/Basic/Vector.pm
Criterion Covered Total %
statement 148 157 94.2
branch 50 68 73.5
condition 11 17 64.7
subroutine 23 24 95.8
pod 9 9 100.0
total 241 275 87.6


line stmt bran cond sub pod time code
1             package Statistics::Basic::Vector;
2              
3 33     33   141 use strict;
  33         38  
  33         1149  
4 33     33   137 use warnings;
  33         34  
  33         769  
5 33     33   129 use Carp;
  33         35  
  33         1862  
6 33     33   153 use Scalar::Util qw(blessed weaken looks_like_number);
  33         47  
  33         3385  
7              
8             our $tag_number = 0;
9              
10 33     33   168 use Statistics::Basic;
  33         53  
  33         315  
11              
12             use overload
13 0     0   0 '0+' => sub { croak "attempt to use vector as scalar numerical value" },
14             '""' => sub {
15 42     42   681 my $this = $_[0];
16 42         57 local $" = ", ";
17 42 100       99 my @r = map { defined $_ ? $Statistics::Basic::fmt->format_number($_, $Statistics::Basic::IPRES) : "_" } $this->query;
  207         12910  
18 42 100       2507 $Statistics::Basic::DEBUG ? "vector-$this->{tag}:[@r]" : "[@r]";
19             },
20 656     656   1374 'bool' => sub { 1 },
21 33     33   179 fallback => 1; # tries to do what it would have done if this wasn't present.
  33         47  
  33         530  
22              
23             # new {{{
24             sub new {
25 294     294 1 1975 my $class = shift;
26 294         290 my $vector = $_[0];
27              
28 294 100 66     2095 if( blessed($vector) and $vector->isa(__PACKAGE__) ) {
29 182 50       313 warn "vector->new called with blessed argument, returning $vector instead of making another\n" if $Statistics::Basic::DEBUG >= 3;
30 182         605 return $vector;
31             }
32              
33 112         593 my $this = bless {tag=>(++$tag_number), s=>0, c=>{}, v=>[]}, $class;
34 112         309 $this->set_vector( @_ );
35              
36 112 50       201 warn "created new vector $this\n" if $Statistics::Basic::DEBUG >= 3;
37              
38 112         693 return $this;
39             }
40             # }}}
41             # copy {{{
42             sub copy {
43 3     3 1 8 my $this = shift;
44 3         4 my $that = __PACKAGE__->new( [@{$this->{v}}] );
  3         15  
45              
46 3 50       9 warn "copied vector($this -> $that)\n" if $Statistics::Basic::DEBUG >= 3;
47              
48 3         11 return $that;
49             }
50             # }}}
51              
52             # _set_computer {{{
53             sub _set_computer {
54 243     243   225 my $this = shift;
55              
56 243         674 while( my ($k,$v) = splice @_, 0, 2 ) {
57 243 100       406 warn "$this set_computer($k => " . overload::StrVal($v) . ")\n" if $Statistics::Basic::DEBUG;
58 243         775 weaken($this->{c}{$k} = $v);
59 243         775 $v->_recalc_needed;
60             }
61              
62 243         315 return;
63             }
64             # }}}
65             # _set_linked_computer {{{
66             sub _set_linked_computer {
67 62     62   65 my $this = shift;
68 62         72 my $key = shift;
69 62         60 my $var = shift;
70              
71 62         82 my $new_key = join("_", ($key, sort {$a<=>$b} map {$_->{tag}} @_));
  0         0  
  62         158  
72              
73 62         106 $this->_set_computer( $new_key => $var );
74              
75 62         85 return;
76             }
77             # }}}
78             # _get_computer {{{
79             sub _get_computer {
80 244     244   239 my $this = shift;
81 244         232 my $k = shift;
82              
83 244 100 50     441 warn "$this get_computer($k): " . overload::StrVal($this->{c}{$k}||"") . "\n" if $Statistics::Basic::DEBUG;
84              
85 244         588 return $this->{c}{$k};
86             }
87             # }}}
88             # _get_linked_computer {{{
89             sub _get_linked_computer {
90 32     32   41 my $this = shift;
91 32         40 my $key = shift;
92              
93 32         54 my $new_key = join("_", ($key, sort {$a<=>$b} map {$_->{tag}} @_));
  0         0  
  32         142  
94              
95 32         83 return $this->_get_computer( $new_key );
96             }
97             # }}}
98             # _inform_computers_of_change {{{
99             sub _inform_computers_of_change {
100 175     175   171 my $this = shift;
101              
102 175         165 for my $k (keys %{ $this->{c} }) {
  175         460  
103 271         340 my $v = $this->{c}{$k};
104              
105 271 100 66     1107 if( defined($v) and blessed($v) ) {
106 268         492 $v->_recalc_needed;
107              
108             } else {
109 3         10 delete $this->{c}{$k};
110             }
111             }
112              
113 175         288 return;
114             }
115             # }}}
116              
117             # _fix_size {{{
118             sub _fix_size {
119 42     42   51 my $this = shift;
120              
121 42         49 my $fixed = 0;
122              
123 42         41 my $d = @{$this->{v}} - $this->{s};
  42         89  
124 42 100       93 if( $d > 0 ) {
125 25         27 splice @{$this->{v}}, 0, $d;
  25         45  
126 25         33 $fixed = 1;
127             }
128              
129 42 100       97 unless( $Statistics::Basic::NOFILL ) {
130 34 100       90 if( $d < 0 ) {
131 8         32 unshift @{$this->{v}}, # unshift so the 0s leave first
  20         36  
132 8         18 map {0} $d .. -1; # add $d of them
133              
134 8         12 $fixed = 1;
135             }
136             }
137              
138 42 50       94 warn "[fix_size $this] [@{ $this->{v} }]\n" if $Statistics::Basic::DEBUG >= 2;
  0         0  
139              
140 42         103 return $fixed;
141             }
142             # }}}
143              
144             # query {{{
145             sub query {
146 328     328 1 308 my $this = shift;
147              
148 328 100       544 return (wantarray ? @{$this->{v}} : $this->{v});
  262         1297  
149             }
150             # }}}
151             # query_filled {{{
152             sub query_filled {
153 185     185 1 178 my $this = shift;
154              
155 185 50       349 warn "[query_filled $this $this->{s}]\n" if $Statistics::Basic::DEBUG >= 1;
156              
157 185 100       159 return if @{$this->{v}} < $this->{s};
  185         437  
158 181         497 return 1;
159             }
160             # }}}
161              
162             # insert {{{
163             sub insert {
164 29     29 1 120 my $this = shift;
165              
166 29 50       81 croak "you must define a vector size before using insert()" unless defined $this->{s};
167              
168 29         60 for my $e (@_) {
169 31 100 100     119 if( ref($e) and not blessed($e) ) {
170 3 50       8 if( ref($e) eq "ARRAY" ) {
171 3         4 push @{ $this->{v} }, @$e;
  3         5  
172 3 50       13 warn "[insert $this] @$e\n" if $Statistics::Basic::DEBUG >= 1;
173              
174             } else {
175 0         0 croak "insert() elements do not make sense";
176             }
177              
178             } else {
179 28         30 push @{ $this->{v} }, $e;
  28         65  
180 28 50       102 warn "[insert $this] $e\n" if $Statistics::Basic::DEBUG >= 1;
181             }
182             }
183              
184 29         70 $this->_fix_size;
185 29         52 $this->_inform_computers_of_change;
186              
187 29         59 return $this;
188             }
189             # }}}
190             # ginsert {{{
191             sub ginsert {
192 39     39 1 50 my $this = shift;
193              
194 39         59 for my $e (@_) {
195 39 100 66     123 if( ref($e) and not blessed($e)) {
196 2 50       7 if( ref($e) eq "ARRAY" ) {
197 2         3 push @{ $this->{v} }, @$e;
  2         5  
198 2 50       10 warn "[ginsert $this] @$e\n" if $Statistics::Basic::DEBUG >= 1;
199              
200             } else {
201 0         0 croak "insert() elements do not make sense";
202             }
203              
204             } else {
205 37         36 push @{ $this->{v} }, $e;
  37         64  
206 37 50       98 warn "[ginsert $this] $e\n" if $Statistics::Basic::DEBUG >= 1;
207             }
208             }
209              
210 39 50       51 $this->{s} = @{$this->{v}} if @{$this->{v}} > $this->{s};
  39         51  
  39         96  
211 39         70 $this->_inform_computers_of_change;
212              
213 39         81 return $this;
214             }
215             *append = \&ginsert;
216             # }}}
217              
218             # query_size {{{
219             sub query_size {
220 322     322 1 1402 my $this = shift;
221              
222 322         288 return scalar @{$this->{v}};
  322         739  
223             }
224              
225             # maybe deprecate this later
226             *size = \&query_size unless $ENV{TEST_AUTHOR};
227              
228             # }}}
229             # set_size {{{
230             sub set_size {
231 13     13 1 25 my $this = shift;
232 13         22 my $size = shift;
233              
234 13 50       53 croak "invalid vector size ($size)" if $size < 0;
235              
236 13 50       55 if( $this->{s} != $size ) {
237 13         26 $this->{s} = $size;
238 13         40 $this->_fix_size;
239 13         33 $this->_inform_computers_of_change;
240             }
241              
242 13         44 return $this;
243             }
244             # }}}
245             # set_vector {{{
246             sub set_vector {
247 160     160 1 696 my $this = shift;
248 160         163 my $vector = $_[0];
249              
250 160 100       844 if( ref($vector) eq "ARRAY" ) {
    50          
    100          
    100          
    50          
251 76         121 @{$this->{v}} = @$vector;
  76         624  
252 76         130 $this->{s} = int @$vector;
253 76         172 $this->_inform_computers_of_change;
254              
255             } elsif( UNIVERSAL::isa($vector, "Statistics::Basic::ComputedVector") ) {
256 0         0 $this->set_vector($vector->{input_vector});
257              
258             } elsif( UNIVERSAL::isa($vector, "Statistics::Basic::Vector") ) {
259 3         5 $this->{s} = $vector->{s};
260 3         4 @{$this->{v}} = @{$vector->{v}}; # copy the vector
  3         14  
  3         5  
261              
262             # I don't think this is the behavior that we really want, since they
263             # stay separate objects, they shouldn't be linked like this.
264             # $this->{s} = $vector->{s};
265             # $this->{v} = $vector->{v}; # this links the vectors together
266             # $this->{c} = $vector->{c}; # so we should link their computers too
267              
268             } elsif( @_ ) {
269 37         47 @{$this->{v}} = @_;
  37         568  
270 37         74 $this->{s} = int @_;
271              
272             } elsif( defined $vector ) {
273 0         0 croak "argument to set_vector() too strange";
274             }
275              
276 160 50 33     405 warn "[set_vector $this] [@{ $this->{v} }]\n" if $Statistics::Basic::DEBUG >= 2 and ref($this->{v});
  0         0  
277              
278 160         240 return $this;
279             }
280             # }}}
281              
282             1;