File Coverage

blib/lib/Quantum/Superpositions/Lazy/Statistics.pm
Criterion Covered Total %
statement 35 37 94.5
branch n/a
condition n/a
subroutine 13 14 92.8
pod 4 4 100.0
total 52 55 94.5


line stmt bran cond sub pod time code
1             package Quantum::Superpositions::Lazy::Statistics;
2              
3             our $VERSION = '1.11';
4              
5 15     15   184 use v5.24;
  15         65  
6 15     15   72 use warnings;
  15         32  
  15         350  
7 15     15   74 use Moo;
  15         29  
  15         76  
8 15     15   4397 use Quantum::Superpositions::Lazy::Role::Collapsible;
  15         31  
  15         467  
9 15     15   75 use Quantum::Superpositions::Lazy::State;
  15         36  
  15         543  
10 15     15   119 use Types::Standard qw(ArrayRef ConsumerOf InstanceOf);
  15         43  
  15         120  
11 15     15   17202 use Sort::Key qw(keysort nkeysort);
  15         40305  
  15         1297  
12 15     15   126 use List::Util qw(sum0);
  15         34  
  15         904  
13              
14             # This approximation should be well within the range of 32 bit
15             # floating point values - 6 digits (IEEE 754)
16 15     15   94 use constant HALF_APPROX => "0.500000";
  15         33  
  15         8461  
17              
18             sub transform_states
19             {
20             my ($items, $transformer) = @_;
21             my @transformed = map {
22             $_->clone_with(value => $transformer)
23             } @$items;
24              
25             return \@transformed;
26             }
27              
28             sub weight_to_probability
29             {
30             my ($item, $weight_sum) = @_;
31             return $item->clone_with(
32             weight => sub { shift() / $weight_sum }
33             ) if defined $item;
34              
35             return $item;
36             }
37              
38             sub weighted_mean
39             {
40             my ($list_ref, $weight_sum) = @_;
41             $weight_sum = sum0 map { $_->weight }
42             $list_ref->@*
43             unless defined $weight_sum;
44              
45             if ($weight_sum > 0) {
46             my @values = map { $_->value * $_->weight / $weight_sum } $list_ref->@*;
47             return sum0 @values;
48             }
49             return undef;
50             }
51              
52             # The sorting order is irrelevant here
53             sub weighted_median
54             {
55             my ($sorted_list_ref, $average) = @_;
56             $average //= 0;
57              
58             my $approx_half = sub {
59             my ($value) = @_;
60              
61             return HALF_APPROX eq substr(($value . (0 x length HALF_APPROX)), 0, length HALF_APPROX);
62             };
63              
64             my $running_sum = 0;
65             my $last_el;
66             my @found;
67              
68             for my $el (@{$sorted_list_ref}) {
69             $running_sum += $el->weight;
70              
71             if ($running_sum > 0.5) {
72             push @found, $last_el if $approx_half->($running_sum - $el->weight);
73             push @found, $el;
74             last;
75             }
76              
77             $last_el = $el;
78             }
79              
80             # if we're allowed to average the result, do that
81             return weighted_mean(\@found)
82             if $average;
83              
84             # get the lowest weight value if we can't average the two
85             # be biased towards the first value
86             return $found[1]->weight < $found[0]->weight ? $found[1]->value : $found[0]->value
87             if @found == 2;
88              
89             return @found > 0 ? $found[0]->value : undef;
90             }
91              
92             # CAUTION: float == comparison inside. Will only work for elements
93             # that were obtained in a similar fasion
94             sub find_border_elements
95             {
96             my ($sorted) = @_;
97             my @found;
98             for my $state (@$sorted) {
99             push @found, $state
100             if @found == 0 || $found[-1]->weight == $state->weight;
101             }
102              
103             return \@found;
104             }
105              
106             my %options = (
107             is => "ro",
108             lazy => 1,
109             init_arg => undef,
110             );
111              
112 15     15   177 use namespace::clean;
  15         40  
  15         125  
113              
114             our $implementation = __PACKAGE__;
115              
116             has "parent" => (
117             is => "ro",
118             isa => ConsumerOf ["Quantum::Superpositions::Lazy::Role::Collapsible"],
119             weak_ref => 1,
120             );
121              
122             # Sorted in ascending order
123             has "sorted_by_probability" => (
124             %options,
125             isa => ArrayRef [InstanceOf ["Quantum::Superpositions::Lazy::State"]],
126             default => sub {
127             my ($self) = @_;
128              
129             [
130             map {
131             weight_to_probability($_, $self->parent->weight_sum)
132             }
133             nkeysort {
134             $_->weight
135             }
136             $self->parent->states->@*
137             ];
138             },
139             );
140              
141             # Sorted in ascending order
142             # (we use sorted_by_probability to avoid copying states twice in weight_to_probability)
143             has "sorted_by_value_str" => (
144             %options,
145             isa => ArrayRef [InstanceOf ["Quantum::Superpositions::Lazy::State"]],
146             default => sub {
147             my ($self) = @_;
148              
149             [
150             keysort { $_->value }
151             $self->sorted_by_probability->@*
152             ];
153             },
154             );
155              
156             has "sorted_by_value_num" => (
157             %options,
158             isa => ArrayRef [InstanceOf ["Quantum::Superpositions::Lazy::State"]],
159             default => sub {
160             my ($self) = @_;
161              
162             [
163             nkeysort { $_->value }
164             $self->sorted_by_probability->@*
165             ];
166             },
167             );
168              
169             # Other consumer indicator
170             has "most_probable" => (
171             %options,
172             isa => InstanceOf ["Quantum::Superpositions::Lazy::Superposition"],
173             default => sub {
174             my ($self) = @_;
175              
176             my @sorted = reverse $self->sorted_by_probability->@*;
177             return Quantum::Superpositions::Lazy::Superposition->new(
178             states => find_border_elements(\@sorted)
179             );
180             },
181             );
182              
183             has "least_probable" => (
184             %options,
185             isa => InstanceOf ["Quantum::Superpositions::Lazy::Superposition"],
186             default => sub {
187             my ($self) = @_;
188              
189             my $sorted = $self->sorted_by_probability;
190             return Quantum::Superpositions::Lazy::Superposition->new(
191             states => find_border_elements($sorted)
192             );
193             },
194             );
195              
196             has "median_str" => (
197             %options,
198             default => sub {
199             my ($self) = @_;
200              
201             weighted_median($self->sorted_by_value_str);
202             },
203             );
204              
205             has "median_num" => (
206             %options,
207             default => sub {
208             my ($self) = @_;
209              
210             weighted_median($self->sorted_by_value_num, 1);
211             },
212             );
213              
214             has "mean" => (
215             %options,
216             default => sub {
217             my ($self) = @_;
218              
219             # since the mean won't return a state, we're free not
220             # to make copies of the states.
221             weighted_mean($self->parent->states, $self->parent->weight_sum);
222             },
223             );
224              
225             has "variance" => (
226             %options,
227             default => sub {
228             my ($self) = @_;
229              
230             # transform_states is required here so that we don't modify existing states
231             weighted_mean(
232             transform_states($self->parent->states, sub { $_[0]**2 }),
233             $self->parent->weight_sum
234             )
235             -
236             $self->mean**2;
237             },
238             );
239              
240             sub sorted_by_value
241             {
242 0     0 1 0 my ($self) = @_;
243 0         0 return $self->sorted_by_value_str;
244             }
245              
246             sub median
247             {
248 5     5 1 3088 my ($self) = @_;
249 5         87 return $self->median_str;
250             }
251              
252             sub expected_value
253             {
254 2     2 1 601 my ($self) = @_;
255 2         41 return $self->mean;
256             }
257              
258             sub standard_deviation
259             {
260 2     2 1 636 my ($self) = @_;
261 2         36 return sqrt $self->variance;
262             }
263              
264             1;
265              
266             __END__