Algorithm-Genetic-Diploid

 view release on metacpan or  search on metacpan

lib/Algorithm/Genetic/Diploid/Base.pm  view on Meta::CPAN

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
=over
 
=item new
 
Base constructor for everyone, takes named arguments
 
=cut
 
sub new {
        my $package = shift;
        $logger->debug("instantiating new $package object");
        my %self = @_;
        $self{'id'} = $id++;
         
        # experiment is provided as an argument
        if ( $self{'experiment'} ) {
                $experiment = $self{'experiment'};
                delete $self{'experiment'};
        }
         
        # create the object

lib/Algorithm/Genetic/Diploid/Chromosome.pm  view on Meta::CPAN

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
 
=item genes
 
Sets and gets list of genes on the chromosome
 
=cut
 
sub genes {
        my $self = shift;
        if ( @_ ) {
                $log->debug("assigning new genes: @_");
                $self->{'genes'} = \@_;
        }
        return @{ $self->{'genes'} };
}
 
=item number
 
Sets and gets chromosome number, i.e. in humans that would be 1..22, X, Y
 
=cut

lib/Algorithm/Genetic/Diploid/Experiment.pm  view on Meta::CPAN

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
 
=item population
 
Getter and setter for the L<Algorithm::Genetic::Diploid::Population> object
 
=cut
 
sub population {
        my $self = shift;
        if ( @_ ) {
                $log->debug("assigning new population: @_");
                $self->{'population'} = shift;
        }
        return $self->{'population'};
}
 
=item run
 
Runs the experiment!
 
=cut

lib/Algorithm/Genetic/Diploid/Individual.pm  view on Meta::CPAN

45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
 
=item chromosomes
 
Getter and setter for the list of chromosomes
 
=cut
 
sub chromosomes {
        my $self = shift;
        if ( @_ ) {
                $log->debug("assigning new chromosomes: @_");
                $self->{'chromosomes'} = \@_;
        }
        return @{ $self->{'chromosomes'} }
}
 
=item meiosis
 
Meiosis produces a gamete, i.e. n chromosomes that have mutated and recombined
 
=cut
 
sub meiosis {
        my $self = shift;
         
        # this is basically mitosis: cloning of chromosomes
        my @chro = map { $_->clone } $self->chromosomes;
        $log->debug("have cloned ".scalar(@chro)." chromosomes (meiosis II)");
         
        # create pairs of homologous chromosomes, i.e. metafase
        my @pairs;
        for my $i ( 0 .. $#chro - 1 ) {
                for my $j ( ( $i + 1 ) .. $#chro ) {
                        if ( $chro[$i]->number == $chro[$j]->number ) {
                                push @pairs, [ $chro[$i], $chro[$j] ];
                        }       
                }
        }

lib/Algorithm/Genetic/Diploid/Individual.pm  view on Meta::CPAN

92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
}
 
=item breed
 
Produces a new individual by mating the invocant with the argument
 
=cut
 
sub breed {
        my ( $self, $mate ) = @_;
        $log->debug("going to breed $self with $mate");
        $self->_increment_cc;
        $mate->_increment_cc;
        __PACKAGE__->new( 
                'chromosomes' => [ $self->meiosis, $mate->meiosis ] 
        );
}
 
=item phenotype
 
Expresses all the genes and weights them to produce a phenotype
 
=cut
 
sub phenotype {
        my ( $self, $env ) = @_;
        $log->debug("computing phenotype in environment $env");
        if ( not defined $self->{'phenotype'} ) {
                my @genes = map { $_->genes } $self->chromosomes;
                my $total_weight = sum map { $_->weight } @genes;
                my $products = sum map { $_->weight * $_->express($env) } @genes;
                $self->{'phenotype'} = $products / $total_weight;
        }
        return $self->{'phenotype'};
}
 
=item fitness
 
The fitness is the difference between the optimum and the phenotype
 
=cut
 
sub fitness {
        my ( $self, $optimum, $env ) = @_;
        my $id = $self->id;
        my $phenotype = $self->phenotype( $env );
        my $diff = abs( $optimum - $phenotype );
        $log->debug("fitness of $id against optimum $optimum is $diff");
        return $diff;
}
 
=back
 
=cut
 
1;

lib/Algorithm/Genetic/Diploid/Logger.pm  view on Meta::CPAN

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
=item INFO
 
Informational messages are transmitted.
 
=cut
 
sub INFO ()  { 3 }
 
=item DEBUG
 
Everything is transmitted, including debugging messages.
 
=cut
 
sub DEBUG () { 4 }
 
# constants mapped to string for AUTOLOAD
my %levels = (
        'fatal' => FATAL,
        'error' => ERROR,
        'warn'  => WARN,
        'info'  => INFO,
        'debug' => DEBUG,
);
 
sub _simple_formatter {
        my %args = @_;
        my ( $level, $sub, $file, $line, $msg ) = @args{('level','sub','file','line','msg')};
        return sprintf "%s %s\n", $level, $msg;
}
 
sub _verbose_formatter {
        my %args = @_;

lib/Algorithm/Genetic/Diploid/Logger.pm  view on Meta::CPAN

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
        my ( $level, $sub, $file, $line, $msg ) = @args{('level','sub','file','line','msg')};
        return sprintf "%s %s [%s] - %s\n", $level, $sub, $line, $msg;
}
 
# this is where methods such as $log->info ultimately are routed to
sub AUTOLOAD {
        my ( $self, $msg ) = @_;
        my $method = $AUTOLOAD;
        $method =~ s/.+://;
         
        # only proceed if method was one of fatal..debug
        if ( exists $levels{$method} ) {
                my ( $package, $file1up, $line1up, $subroutine ) = caller( 1 );
                my ( $pack0up, $filename, $line, $sub0up )       = caller( 0 );
                 
                # calculate what the verbosity is for the current context
                # (either at sub, package or global level)
                my $verbosity;
                if ( exists $VERBOSE{$subroutine} ) {
                        $verbosity = $VERBOSE{$subroutine};
                }

lib/Algorithm/Genetic/Diploid/Population.pm  view on Meta::CPAN

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
=item individuals
 
Getter and setter for the list of individuals
 
=cut
 
sub individuals {
        my $self = shift;
        if ( @_ ) {
                $self->{'individuals'} = \@_;
                $log->debug("assigning ".scalar(@_)." individuals to population");
        }
        return @{ $self->{'individuals'} };
}
 
=item turnover
 
Moves the population on to the next generation, i.e.
1. compute fitness of all individuals
2. mate up to reproduction rate in proportion to fitness
 
=cut
 
sub turnover {
        my ( $self, $gen, $env, $optimum ) = @_;
        my $log = $self->logger;
        $log->debug("going to breed generation $gen against optimum $optimum");
         
        # sort all individuals by fitness, creates array refs 
        # where 0 element is Individual, 1 element is its fitness
        my @fittest = sort { $a->[1] <=> $b->[1] } 
                       map { [ $_, $_->fitness($optimum,$env) ] } 
                       $self->individuals;
        $log->debug("sorted current generation by fitness");
        $log->info("*** fittest at generation $gen: ".$fittest[0]->[0]->phenotype($env));
                        
        # get the highest index of Individual 
        # that still gets to reproduce
        my $maxidx = int( $self->experiment->reproduction_rate * $#fittest );
        $log->debug("individuals up to index $maxidx will breed");
         
        # take the slice of Individuals that get to reproduce
        my @breeders = @fittest[ 0 .. $maxidx ];
        $log->debug("number of breeders: ".scalar(@breeders));
         
        # compute the total fitness, to know how much each breeder gets to
        # contribute to the next generation
        my $total_fitness = sum map { $_->[1] } @breeders;
        $log->debug("total fitness is $total_fitness");
         
        # compute the population size, which we need to divide up over the
        # breeders in proportion of their fitness relative to total fitness
        my $popsize = scalar $self->individuals;
        $log->debug("population size will be $popsize");
         
        # here we make breeding pairs
        my @children;
        ORGY: while( @children < $popsize ) {
                for my $i ( 0 .. $#breeders ) {
                        my $quotum_i = $breeders[$i]->[1] / $total_fitness * $popsize * 2;
                        for my $j ( 0 .. $#breeders ) {
                                my $quotum_j = $breeders[$j]->[1] / $total_fitness * $popsize * 2;
                                my $count_i  = $breeders[$i]->[0]->child_count;
                                my $count_j  = $breeders[$j]->[0]->child_count;
                                if ( $count_i < $quotum_i && $count_j < $quotum_j ) {
                                        push @children, $breeders[$i]->[0]->breed($breeders[$j]->[0]);
                                        $log->debug("bred child ".scalar(@children)." by pairing $i and $j");
                                        last ORGY if @children == $popsize;
                                }                               
                        }
                }
        }
         
        my %genes = map { $_->id => 1 } map { $_->genes } map { $_->chromosomes } @children;
        $log->debug("generation $gen has ".scalar(keys(%genes))." distinct genes");
         
        # now the population consists of the children
        $self->individuals(@children);
        return @{ $fittest[0] };
}
 
=back
 
=cut