File Coverage

blib/lib/Vote/Count/Charge/Cascade.pm
Criterion Covered Total %
statement 171 174 98.2
branch 32 36 88.8
condition 6 6 100.0
subroutine 25 25 100.0
pod 0 5 0.0
total 234 246 95.1


line stmt bran cond sub pod time code
1 4     4   937909 use strict;
  4         36  
  4         112  
2 4     4   22 use warnings;
  4         7  
  4         93  
3 4     4   107 use 5.024;
  4         16  
4              
5             use namespace::autoclean;
6 4     4   1742 use Moose;
  4         69811  
  4         16  
7 4     4   2316 extends 'Vote::Count::Charge';
  4         1841060  
  4         30  
8             # with 'Vote::Count::Charge::NthApproval';
9              
10             no warnings 'experimental';
11 4     4   33652 use feature qw /postderef signatures/;
  4         9  
  4         224  
12 4     4   28  
  4         9  
  4         601  
13             use Storable 3.15 'dclone';
14 4     4   3025 use Mojo::Template;
  4         16514  
  4         273  
15 4     4   2060 use Sort::Hash;
  4         819919  
  4         44  
16 4     4   1990 use Data::Dumper;
  4         3562  
  4         212  
17 4     4   41 use Try::Tiny;
  4         9  
  4         199  
18 4     4   27 use JSON::MaybeXS;
  4         9  
  4         177  
19 4     4   2036 use YAML::XS;
  4         24649  
  4         239  
20 4     4   1683 use Path::Tiny;
  4         10756  
  4         225  
21 4     4   3451 use Carp;
  4         48554  
  4         271  
22 4     4   34 use Vote::Count::Helper::FullCascadeCharge;
  4         14  
  4         234  
23 4     4   2029  
  4         16  
  4         7200  
24             our $VERSION='2.02';
25              
26             =head1 NAME
27              
28             Vote::Count::Charge::Cascade
29              
30             =head1 VERSION 2.02
31              
32             =cut
33              
34             has 'VoteValue' => (
35             is => 'ro',
36             isa => 'Int',
37             default => 100000,
38             );
39              
40             has 'IterationLog' => (
41             is => 'rw',
42             isa => 'Str',
43             required => 0,
44             );
45              
46             has 'EstimationRule' => (
47             is => 'ro',
48             isa => 'Str',
49             default => 'estimate',
50             );
51              
52             has 'EstimationFresh' => (
53             is => 'ro',
54             isa => 'Bool',
55             default => 0,
56             );
57              
58             has 'TieBreakMethod' => (
59             is => 'rw',
60             isa => 'Str',
61             default => ''
62             );
63              
64             my $I = shift;
65             # $I->TieBreakMethod('precedence');
66 13     13 0 48 $I->TieBreakerFallBackPrecedence(1);
67             $I->{'roundstatus'} = { 0 => {} };
68 13         416 $I->{'currentround'} = 0;
69 13         68 # to hold the last charged values for elected choices.
70 13         44 $I->{'lastcharge'} = {};
71             }
72 13         402  
73             our $coder = JSON->new->ascii->pretty;
74              
75              
76             # quota and charge of from previous round!
77 7     7 0 17 $I->TopCount();
  7         14  
  7         12  
  7         23  
78             my $round = ++$I->{'currentround'};
79             $I->{'roundstatus'}{ $round - 1 } = {
80 11     11 0 1610 'charge' => $charge,
  11         21  
  11         31  
  11         23  
  11         23  
81 11         100 'quota' => $quota,
82 11         58 };
83 11         78 if ( keys $charge->%* ) { $I->{'lastcharge'} = $charge }
84             return $round;
85             }
86              
87 11 100       63 my $estrule = $I->EstimationRule();
  5         17  
88 11         86 my $lastround = $I->{'currentround'} ? $I->{'currentround'} - 1 : 0;
89             my $lastcharge = $I->{'lastcharge'};
90             my $unw = $I->LastTopCountUnWeighted();
91 13     13   5320 die 'LastTopCountUnWeighted failed' unless ( keys $unw->%* );
  13         30  
  13         25  
  13         36  
  13         20  
92 13         521 my %estimate = ();
93 13 100       59 my %caps = ();
94 13         33 if ( $I->EstimationFresh && $I->EstimationRule eq 'estimate') {
95 13         367 die "Fresh Estimation is not compatible with EstimationRule estimate, because prior winners are not in current top count!";
96 13 100       76 }
97 12         32 for my $e (@elected) {
98 12         21 if ( $I->{'lastcharge'}{$e} && ! $I->EstimationFresh ) {
99 12 100 100     375 $estimate{$e} = $I->{'lastcharge'}{$e};
100 1         18 $caps{$e} = $I->{'lastcharge'}{$e};
101             }
102 11         37 else {
103 25 100 100     376 if ($estrule eq 'estimate') { $estimate{$e} = int( $quota / $unw->{$e} ) }
104 5         17 elsif ( $estrule eq 'votevalue' ) { $estimate{$e} = $I->VoteValue }
105 5         14 elsif ( $estrule eq 'zero') { $estimate{$e} = 0 }
106             elsif ( $estrule eq 'halfvalue' ){ $estimate{$e} = int( $I->VoteValue / 2 ) }
107             $caps{$e} = $I->VoteValue;
108 20 100       77 }
  13 100       52  
    100          
    50          
109 3         90 }
110 2         5 return ( \%estimate, \%caps );
111 2         56 }
112 20         561  
113             # Must move directly to charge after this
114             # --- if another topcount happens estimate will crash!
115 11         59 my %TC = $I->TopCount()->RawCount()->%*;
116             my @Electable = ();
117             for my $C ( keys %TC ) {
118             if ( $TC{$C} >= $quota ) {
119             $I->Elect($C);
120 3     3 0 25 push @Electable, $C;
  3         8  
  3         6  
  3         8  
121 3         18 }
122 3         25 }
123 3         12 return @Electable;
124 13 100       36 }
125 4         29  
126 4         13 # Produce a better estimate than the previous by running
127             # FullCascadeCharge of the last estimate. Clones a copy of
128             # Ballots for the Cascade Charge.
129 3         19 my $active = $I->GetActive();
130             my %estnew = ();
131             # make sure a new freeze is applied before charge evaluation.
132             for my $froz ( keys $freeze->%* ) {
133             $est->{$froz} = $freeze->{$froz} if $freeze->{$froz};
134             }
135 29     29   3521 my %elect = map { $_ => 1 } (@elected);
  29         46  
  29         46  
  29         54  
  29         52  
  29         44  
  29         40  
  29         72  
  29         43  
136 29         149 my $B = dclone $I->GetBallots();
137 29         104 my $charge =
138             FullCascadeCharge( $B, $quota, $est, $active, $I->VoteValue() );
139 29         101 LOOPINSIGHT: for my $E (@elected) {
140 70 50       174 if ( $freeze->{$E} ) { # if frozen stay frozen.
141             $estnew{$E} = $freeze->{$E};
142 29         83 next LOOPINSIGHT;
  76         200  
143 29         113 }
144 29         1268 elsif ( $charge->{$E}{'surplus'} >= 0 ) {
145             $estnew{$E} =
146 29         79 $est->{$E} - int( $charge->{$E}{'surplus'} / $charge->{$E}{'count'} );
147 76 50       212 }
    100          
148 0         0 else {
149 0         0 $estnew{$E} = $est->{$E} -
150             ( int( $charge->{$E}{'surplus'} / $charge->{$E}{'count'} ) ) + 1 ;
151             }
152             $estnew{$E} = $cap->{$E} if $cap->{$E} < $estnew{$E}; # apply cap.
153 43         188 $estnew{$E} = $bottom->{$E}
154             if $bottom->{$E} > $estnew{$E}; # apply bottom.
155             }
156             return { 'result' => $charge, 'estimate' => \%estnew };
157 33         102 }
158              
159 76 100       185 if( $I->IterationLog() ) {
160             my $jsonpath = $I->IterationLog() . ".$round.json";
161 76 100       182 my $yamlpath = $I->IterationLog() . ".$round.yaml";
162             path( $jsonpath )->spew( $coder->encode( $data ) );
163 29         18458 path( $yamlpath )->spew( Dump $data );
164             }
165             }
166 5     5   12  
  5         15  
  5         10  
  5         10  
  5         11  
167 5 100       281 my @elected = $I->Elected();
168 2         64 my $round = $I->Round();
169 2         62 my $estimates = {};
170 2         20 my $iteration = 0;
171 2         1912 my $freeze = { map { $_ => 0 } @elected };
172             my $bottom = { map { $_ => 0 } @elected };
173             my ( $estimate, $cap ) = _preEstimate( $I, $quota, @elected );
174             $estimates->{$iteration} = $estimate;
175 6     6 0 1459 my $done = 0;
  6         17  
  6         11  
  6         14  
176 6         32 my $charged = undef ; # the last value from loop is needed for log.
177 6         30 until ( $done ) {
178 6         17 ++$iteration;
179 6         14 if ( $iteration > 100 ) { die "Exceeded Iteration Limit!\n"}
180 6         19 # for ( $estimate, $cap, $bottom, $freeze, @elected ) { warn Dumper $_}
  13         51  
181 6         19 $charged =
  13         28  
182 6         29 _chargeInsight( $I, $quota, $estimate, $cap, $bottom, $freeze,
183 5         18 @elected );
184 5         12 $estimate = $charged->{'estimate'};
185 5         11 $estimates->{$iteration} = $charged->{'estimate'};
186 5         15 $done = 1;
187 26         54 for my $V (@elected) {
188 26 50       71 my $est1 = $estimates->{$iteration}{$V};
  0         0  
189             my $est2 = $estimates->{ $iteration - 1 }{$V};
190             if ( $est1 != $est2 ) { $done = 0 }
191 26         87 }
192             }
193 26         94 _write_iteration_log( $I, $round, {
194 26         98 estimates => $estimates,
195 26         49 quota => $quota,
196 26         58 charge => $estimate,
197 70         120 iterations => $iteration,
198 70         141 detail => $charged->{'result'} } );
199 70 100       162  
  35         86  
200             $I->STVEvent( {
201             round => $round,
202             quota => $quota,
203             charge => $estimate,
204             iterations => $iteration,
205             detail => $charged->{'result'}
206             } );
207 5         103 return $estimate;
208             }
209              
210             __PACKAGE__->meta->make_immutable;
211             1;
212              
213             #FOOTER
214 5         1497  
215             =pod
216 5         49  
217             BUG TRACKER
218              
219             L<https://github.com/brainbuz/Vote-Count/issues>
220              
221             AUTHOR
222              
223             John Karr (BRAINBUZ) brainbuz@cpan.org
224              
225             CONTRIBUTORS
226              
227             Copyright 2019-2021 by John Karr (BRAINBUZ) brainbuz@cpan.org.
228              
229             LICENSE
230              
231             This module is released under the GNU Public License Version 3. See license file for details. For more information on this license visit L<http://fsf.org>.
232              
233             SUPPORT
234              
235             This software is provided as is, per the terms of the GNU Public License. Professional support and customisation services are available from the author.
236              
237             =cut
238