Algorithm-Genetic-Diploid

 view release on metacpan or  search on metacpan

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

=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

=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

=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

=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

}

=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

=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

	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

=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