File Coverage

lib/Algorithm/Evolutionary/Op/Generation_Skeleton.pm

Criterion	Covered	Total	%
statement	15	15	100.0
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	20	20	100.0

use strict;
use warnings;

=head1 NAME

Algorithm::Evolutionary::Op::Generation_Skeleton - Even more customizable single generation for an evolutionary algorithm.

=head1 SYNOPSIS

    use Algorithm::Evolutionary qw( Individual::BitString
				Op::Mutation Op::Crossover
				Op::RouletteWheel
				Fitness::ONEMAX Op::Generation_Skeleton
				Op::Replace_Worst);

    use Algorithm::Evolutionary::Utils qw(average);

    my $onemax = new Algorithm::Evolutionary::Fitness::ONEMAX;

    my @pop;
    my $number_of_bits = 20;
    my $population_size = 20;
    my $replacement_rate = 0.5;
    for ( 1..$population_size ) {
      my $indi = new Algorithm::Evolutionary::Individual::BitString $number_of_bits ; #Creates random individual
      $indi->evaluate( $onemax );
      push( @pop, $indi );
    }

    my $m =  new Algorithm::Evolutionary::Op::Mutation 0.5;
    my $c = new Algorithm::Evolutionary::Op::Crossover; #Classical 2-point crossover

    my $selector = new Algorithm::Evolutionary::Op::RouletteWheel $population_size; #One of the possible selectors

    my $generation =
      new Algorithm::Evolutionary::Op::Generation_Skeleton( $onemax, $selector, [$m, $c], $replacement_rate );

    my @sortPop = sort { $b->Fitness() <=> $a->Fitness() } @pop;
    my $bestIndi = $sortPop[0];
    my $previous_average = average( \@sortPop );
    $generation->apply( \@sortPop );

=head1 Base Class

L

=head1 DESCRIPTION

Skeleton class for a general single-generation (or single step) in an
evolutionary algorithm; its instantiation requires a
L function, a
L, a reference to an
array of operators and a replacement operator

=head1 METHODS

=cut

package Algorithm::Evolutionary::Op::Generation_Skeleton;

use lib qw(../../..);

our ($VERSION) = ( '$Revision: 3.3 $ ' =~ / (\d+\.\d+)/ ) ;

use Carp;

use base 'Algorithm::Evolutionary::Op::Base';

use Algorithm::Evolutionary qw(Wheel Op::Replace_Worst);
use Sort::Key qw( rnkeysort);

# Class-wide constants
our $APPLIESTO =  'ARRAY';
our $ARITY = 1;

=head2 new( $evaluation_function, $selector, $ref_to_operator_array, $replacement_operator )

Creates an algorithm, with no defaults except for the default
replacement operator (defaults to L)

=cut

sub new {
  my $class = shift;
  my $self = {};
  $self->{_eval} = shift || croak "No eval function found";
  $self->{_selector} = shift || croak "No selector found";
  $self->{_ops} = shift || croak "No operators found";
  $self->{_replacementRate} = shift || 1; #Default to all  replaced
  $self->{_replacement_op} = shift || new Algorithm::Evolutionary::Op::Replace_Worst;
  bless $self, $class;
  return $self;
}


=head2 set( $ref_to_params_hash, $ref_to_code_hash, $ref_to_operators_hash )

Sets the instance variables. Takes a ref-to-hash as
input. Not intended to be used from outside the class

=cut

sub set {
  my $self = shift;
  my $hashref = shift || croak "No params here";
  my $codehash = shift || croak "No code here";
  my $opshash = shift || croak "No ops here";

  for ( keys %$codehash ) {
	$self->{"_$_"} =  eval "sub { $codehash->{$_} } ";
  }

  $self->{_ops} =();
  for ( keys %$opshash ) {
    push @{$self->{_ops}},
      Algorithm::Evolutionary::Op::Base::fromXML( $_, $opshash->{$_}->[1], $opshash->{$_}->[0] ) ;
  }
}

=head2 apply( $population )

Applies the algorithm to the population, which should have
been evaluated first; checks that it receives a
ref-to-array as input, croaks if it does not. Returns a sorted,
culled, evaluated population for next generation.

=cut

sub apply ($) {
    my $self = shift;
    my $pop = shift || croak "No population here";
    croak "Incorrect type ".(ref $pop) if  ref( $pop ) ne $APPLIESTO;

    #Evaluate only the new ones
    my $eval = $self->{'_eval'};
    my @ops = @{$self->{'_ops'}};

    #Breed
    my $selector = $self->{'_selector'};
    my @genitors = $selector->apply( @$pop );

    #Reproduce
    my $totRate = 0;
    my @rates;
    for ( @ops ) {
	push( @rates, $_->{'rate'});
    }
    my $opWheel = new Algorithm::Evolutionary::Wheel @rates;

    my @newpop;
    my $pringaos =  @$pop  * $self->{'_replacementRate'} ;
    for ( my $i = 0; $i < $pringaos; $i++ ) {
	my @offspring;
	my $selectedOp = $ops[ $opWheel->spin()];
#	  print $selectedOp->asXML;
	for ( my $j = 0; $j < $selectedOp->arity(); $j ++ ) {
	    my $chosen = $genitors[ rand( @genitors )];
#		print "Elegido ", $chosen->asString(), "\n";
	    push( @offspring, $chosen->clone() );
	}
	my $mutante = $selectedOp->apply( @offspring );
	push( @newpop, $mutante );
    }

    #Eliminate and substitute
    map( $_->evaluate( $eval), @newpop );
    my $pop_hash = $self->{'_replacement_op'}->apply( $pop, \@newpop );
    @$pop = rnkeysort { $_->{'_fitness'} } @$pop_hash ;
}

=head1 SEE ALSO

More or less in the same ballpark, alternatives to this one

=over 4

=item *

L

=back

=head1 Copyright

This file is released under the GPL. See the LICENSE file included in this distribution,
or go to http://www.fsf.org/licenses/gpl.txt

  CVS Info: $Date: 2013/01/05 12:43:32 $
  $Header: /media/Backup/Repos/opeal/opeal/Algorithm-Evolutionary/lib/Algorithm/Evolutionary/Op/Generation_Skeleton.pm,v 3.3 2013/01/05 12:43:32 jmerelo Exp $
  $Author: jmerelo $
  $Revision: 3.3 $

=cut

"The truth is out there";