File Coverage

lib/Algorithm/Evolutionary/Wheel.pm
Criterion Covered Total %
statement 50 50 100.0
branch 5 6 83.3
condition 3 5 60.0
subroutine 6 6 100.0
pod 3 3 100.0
total 67 70 95.7


line stmt bran cond sub pod time code
1 4     4   24393 use strict;
  4         8  
  4         137  
2 4     4   18 use warnings;
  4         9  
  4         156  
3              
4             =head1 NAME
5              
6             Algorithm::Evolutionary::Wheel - Random selector of things depending on probabilities
7              
8             =head1 SYNOPSIS
9              
10             my $wheel = new Algorithm::Evolutionary::Wheel( @probs );
11             print $wheel->spin(); #Returns an element according to probabilities;
12              
13             =head1 DESCRIPTION
14              
15             Creates a "roulette wheel" for spinning and selecting stuff. It will
16             be used in several places; mainly in the
17             L. Take care that fitness
18             must be non-zero positives; since if they aren't, roulette wheel won't
19             work at all
20              
21             =head1 METHODS
22              
23             =cut
24              
25             package Algorithm::Evolutionary::Wheel;
26 4     4   32 use Carp;
  4         8  
  4         2279  
27              
28             our ($VERSION) = ( '$Revision: 3.6 $ ' =~ / (\d+\.\d+)/ ) ;
29              
30             =head2 new( @probabilites )
31              
32             Creates a new roulette wheel. Takes an array of numbers, which need not be
33             normalized
34              
35             =cut
36              
37             sub new {
38 1     1 1 17 my $class = shift;
39 1         3 my @probs = @_;
40            
41 1         2 my $self;
42 1         3 $self->{'_accProbs'} = [ 0 ];
43            
44 1         2 my $acc = 0;
45 1         2 for ( @probs ) { $acc += $_;}
  5         9  
46 1 50       3 croak "The sum of fitness is 0, can't use roulette wheel\n" if ! $acc;
47 1         2 for ( @probs ) { $_ /= $acc;} #Normalizes array
  5         8  
48            
49             #Now creates the accumulated array
50 1         2 my $aux = 0;
51 1         2 for ( @probs ) {
52 5         6 push @{$self->{'_accProbs'}}, $_ + $aux;
  5         8  
53 5         8 $aux += $_;
54             }
55 1         2 bless $self, $class;
56 1         4 return $self;
57             }
58              
59             =head2 spin( [$number_of_individuals = 1])
60              
61             Returns an individual whose probability is related to its fitness
62              
63             =cut
64              
65             sub spin {
66 104     104 1 68407 my $self = shift;
67 104   100     426 my $number_of_individuals = shift || 1;
68 104         104 my $i = 0;
69 104         107 my @rand;
70 104         197 for my $n ( 1..$number_of_individuals ) {
71 114         348 push @rand, rand();
72             }
73 104         134 my @individuals;
74 104         280 for ( my $r=0; $r<= $#rand; $r++ ) {
75 114         269 my $i = first( $rand[$r], $self->{'_accProbs'} );
76             # my $i = -1; # First iteration must be 0
77             # do {
78             # $i++;
79             # } until (( $acc_probs[$i+1] > $rand[$r] ) || ($i >= $#acc_probs ));
80             # $individuals[$r] = $i;
81 114         305 push @individuals, $i;
82             }
83 104 100       170 if ( $number_of_individuals > 1 ) {
84 4         20 return @individuals;
85             } else {
86 100         327 return $individuals[0];
87             }
88            
89             }
90              
91             =head2 first( $item, $ref_to_list )
92              
93             Returns the index of the first individual smaller than the item
94              
95             =cut
96              
97             sub first {
98 114     114 1 135 my $item = shift;
99 114   33     467 my $list = shift || croak "No list";
100 114         117 my $first=0;
101 114         814 my $last= scalar @$list -1;
102 114         294 my $mid=int($last/2);
103 114         192 while ($first <= $last ) {
104 342 100       582 if ( $item > $list->[$mid] ) {
105 205         405 $first = $mid + 1;
106             } else {
107 137         136 $last = $mid -1;
108             }
109 342         856 $mid = $first+ int(($last - $first )/2);
110             }
111 114         259 return $last;
112            
113             }
114             =head1 Copyright
115            
116             This file is released under the GPL. See the LICENSE file included in this distribution,
117             or go to http://www.fsf.org/licenses/gpl.txt
118              
119             CVS Info: $Date: 2010/12/08 09:31:24 $
120             $Header: /media/Backup/Repos/opeal/opeal/Algorithm-Evolutionary/lib/Algorithm/Evolutionary/Wheel.pm,v 3.6 2010/12/08 09:31:24 jmerelo Exp $
121             $Author: jmerelo $
122              
123             =cut
124              
125             "The truth is by here";
126              
127             #Test code
128             #my @array = qw( 5 4 3 2 1 );
129             #my $wheel = new Wheel @array;
130              
131             #my @histo;
132             #for ( 0..100 ){
133             # my $s = $wheel->spin();
134             # print "$s\n";
135             # $histo[$s]++;
136             #}
137              
138             #for ( 0..(@histo - 1)){
139             # print $_, " => $histo[$_] \n";
140             #}
141              
142             #my @array2 = qw( 1 3 7 4 2 1 );
143             #my $wheel2 = new Wheel @array2;
144              
145             #my @histo2;
146             #for ( 0..100 ){
147             # my $s = $wheel2->spin();
148             # print "$s\n";
149             # $histo2[$s]++;
150             #}
151              
152             #for ( 0..(@histo2 - 1)){
153             # print $_, " => $histo2[$_] \n";
154             #}