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   158 use strict;
  33         45  
  33         1315  
4 33     33   152 use warnings;
  33         39  
  33         900  
5 33     33   145 use Carp;
  33         50  
  33         2079  
6 33     33   171 use Scalar::Util qw(blessed weaken looks_like_number);
  33         115  
  33         3920  
7              
8             our $tag_number = 0;
9              
10 33     33   204 use Statistics::Basic;
  33         70  
  33         338  
11              
12             use overload
13 0     0   0 '0+' => sub { croak "attempt to use vector as scalar numerical value" },
14             '""' => sub {
15 42     42   691 my $this = $_[0];
16 42         59 local $" = ", ";
17 42 100       109 my @r = map { defined $_ ? $Statistics::Basic::fmt->format_number($_, $Statistics::Basic::IPRES) : "_" } $this->query;
  207         9842  
18 42 100       4609 $Statistics::Basic::DEBUG ? "vector-$this->{tag}:[@r]" : "[@r]";
19             },
20 656     656   1464 'bool' => sub { 1 },
21 33     33   207 fallback => 1; # tries to do what it would have done if this wasn't present.
  33         75  
  33         678  
22              
23             # new {{{
24             sub new {
25 294     294 1 1610 my $class = shift;
26 294         316 my $vector = $_[0];
27              
28 294 100 66     2274 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         604 return $vector;
31             }
32              
33 112         621 my $this = bless {tag=>(++$tag_number), s=>0, c=>{}, v=>[]}, $class;
34 112         335 $this->set_vector( @_ );
35              
36 112 50       279 warn "created new vector $this\n" if $Statistics::Basic::DEBUG >= 3;
37              
38 112         689 return $this;
39             }
40             # }}}
41             # copy {{{
42             sub copy {
43 3     3 1 7 my $this = shift;
44 3         5 my $that = __PACKAGE__->new( [@{$this->{v}}] );
  3         10  
45              
46 3 50       9 warn "copied vector($this -> $that)\n" if $Statistics::Basic::DEBUG >= 3;
47              
48 3         5 return $that;
49             }
50             # }}}
51              
52             # _set_computer {{{
53             sub _set_computer {
54 243     243   235 my $this = shift;
55              
56 243         786 while( my ($k,$v) = splice @_, 0, 2 ) {
57 243 100       449 warn "$this set_computer($k => " . overload::StrVal($v) . ")\n" if $Statistics::Basic::DEBUG;
58 243         843 weaken($this->{c}{$k} = $v);
59 243         904 $v->_recalc_needed;
60             }
61              
62 243         326 return;
63             }
64             # }}}
65             # _set_linked_computer {{{
66             sub _set_linked_computer {
67 62     62   56 my $this = shift;
68 62         65 my $key = shift;
69 62         58 my $var = shift;
70              
71 62         88 my $new_key = join("_", ($key, sort {$a<=>$b} map {$_->{tag}} @_));
  0         0  
  62         196  
72              
73 62         106 $this->_set_computer( $new_key => $var );
74              
75 62         92 return;
76             }
77             # }}}
78             # _get_computer {{{
79             sub _get_computer {
80 244     244   264 my $this = shift;
81 244         243 my $k = shift;
82              
83 244 100 50     427 warn "$this get_computer($k): " . overload::StrVal($this->{c}{$k}||"") . "\n" if $Statistics::Basic::DEBUG;
84              
85 244         616 return $this->{c}{$k};
86             }
87             # }}}
88             # _get_linked_computer {{{
89             sub _get_linked_computer {
90 32     32   37 my $this = shift;
91 32         40 my $key = shift;
92              
93 32         62 my $new_key = join("_", ($key, sort {$a<=>$b} map {$_->{tag}} @_));
  0         0  
  32         141  
94              
95 32         81 return $this->_get_computer( $new_key );
96             }
97             # }}}
98             # _inform_computers_of_change {{{
99             sub _inform_computers_of_change {
100 175     175   200 my $this = shift;
101              
102 175         173 for my $k (keys %{ $this->{c} }) {
  175         537  
103 271         323 my $v = $this->{c}{$k};
104              
105 271 100 66     1154 if( defined($v) and blessed($v) ) {
106 268         616 $v->_recalc_needed;
107              
108             } else {
109 3         5 delete $this->{c}{$k};
110             }
111             }
112              
113 175         298 return;
114             }
115             # }}}
116              
117             # _fix_size {{{
118             sub _fix_size {
119 42     42   56 my $this = shift;
120              
121 42         58 my $fixed = 0;
122              
123 42         49 my $d = @{$this->{v}} - $this->{s};
  42         111  
124 42 100       113 if( $d > 0 ) {
125 25         44 splice @{$this->{v}}, 0, $d;
  25         56  
126 25         206 $fixed = 1;
127             }
128              
129 42 100       134 unless( $Statistics::Basic::NOFILL ) {
130 34 100       88 if( $d < 0 ) {
131 8         30 unshift @{$this->{v}}, # unshift so the 0s leave first
  20         34  
132 8         13 map {0} $d .. -1; # add $d of them
133              
134 8         18 $fixed = 1;
135             }
136             }
137              
138 42 50       192 warn "[fix_size $this] [@{ $this->{v} }]\n" if $Statistics::Basic::DEBUG >= 2;
  0         0  
139              
140 42         69 return $fixed;
141             }
142             # }}}
143              
144             # query {{{
145             sub query {
146 328     328 1 350 my $this = shift;
147              
148 328 100       638 return (wantarray ? @{$this->{v}} : $this->{v});
  262         1455  
149             }
150             # }}}
151             # query_filled {{{
152             sub query_filled {
153 185     185 1 184 my $this = shift;
154              
155 185 50       346 warn "[query_filled $this $this->{s}]\n" if $Statistics::Basic::DEBUG >= 1;
156              
157 185 100       164 return if @{$this->{v}} < $this->{s};
  185         478  
158 181         482 return 1;
159             }
160             # }}}
161              
162             # insert {{{
163             sub insert {
164 29     29 1 389 my $this = shift;
165              
166 29 50       96 croak "you must define a vector size before using insert()" unless defined $this->{s};
167              
168 29         63 for my $e (@_) {
169 31 100 100     142 if( ref($e) and not blessed($e) ) {
170 3 50       6 if( ref($e) eq "ARRAY" ) {
171 3         5 push @{ $this->{v} }, @$e;
  3         6  
172 3 50       9 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         34 push @{ $this->{v} }, $e;
  28         92  
180 28 50       112 warn "[insert $this] $e\n" if $Statistics::Basic::DEBUG >= 1;
181             }
182             }
183              
184 29         96 $this->_fix_size;
185 29         70 $this->_inform_computers_of_change;
186              
187 29         64 return $this;
188             }
189             # }}}
190             # ginsert {{{
191             sub ginsert {
192 39     39 1 57 my $this = shift;
193              
194 39         65 for my $e (@_) {
195 39 100 66     118 if( ref($e) and not blessed($e)) {
196 2 50       5 if( ref($e) eq "ARRAY" ) {
197 2         1 push @{ $this->{v} }, @$e;
  2         4  
198 2 50       11 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         75  
206 37 50       104 warn "[ginsert $this] $e\n" if $Statistics::Basic::DEBUG >= 1;
207             }
208             }
209              
210 39 50       65 $this->{s} = @{$this->{v}} if @{$this->{v}} > $this->{s};
  39         65  
  39         113  
211 39         66 $this->_inform_computers_of_change;
212              
213 39         77 return $this;
214             }
215             *append = \&ginsert;
216             # }}}
217              
218             # query_size {{{
219             sub query_size {
220 322     322 1 888 my $this = shift;
221              
222 322         314 return scalar @{$this->{v}};
  322         758  
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 22 my $this = shift;
232 13         17 my $size = shift;
233              
234 13 50       59 croak "invalid vector size ($size)" if $size < 0;
235              
236 13 50       136 if( $this->{s} != $size ) {
237 13         29 $this->{s} = $size;
238 13         42 $this->_fix_size;
239 13         35 $this->_inform_computers_of_change;
240             }
241              
242 13         42 return $this;
243             }
244             # }}}
245             # set_vector {{{
246             sub set_vector {
247 160     160 1 1082 my $this = shift;
248 160         195 my $vector = $_[0];
249              
250 160 100       904 if( ref($vector) eq "ARRAY" ) {
    50          
    100          
    100          
    50          
251 76         111 @{$this->{v}} = @$vector;
  76         658  
252 76         168 $this->{s} = int @$vector;
253 76         170 $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         10 $this->{s} = $vector->{s};
260 3         5 @{$this->{v}} = @{$vector->{v}}; # copy the vector
  3         17  
  3         9  
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         78 @{$this->{v}} = @_;
  37         640  
270 37         90 $this->{s} = int @_;
271              
272             } elsif( defined $vector ) {
273 0         0 croak "argument to set_vector() too strange";
274             }
275              
276 160 50 33     471 warn "[set_vector $this] [@{ $this->{v} }]\n" if $Statistics::Basic::DEBUG >= 2 and ref($this->{v});
  0         0  
277              
278 160         256 return $this;
279             }
280             # }}}
281              
282             1;