view release on metacpan or  search on metacpan

lib/AI/FANN/Evolving.pm  view on Meta::CPAN

		%{ $self } = %{ $ann };
		
		# instantiate the network dimensions
		$self->{'ann'} = AI::FANN->new_standard(
			$ann->num_inputs, 
			$ann->num_inputs + 1,
			$ann->num_outputs,
		);
		
		# copy the AI::FANN properties
		$ann->template($self->{'ann'});
		return $self;
	}
	else {
		die "Need 'file', 'data' or 'ann' argument!";
	}
}

=item template

Uses the object as a template for the properties of the argument, e.g.
$ann1->template($ann2) applies the properties of $ann1 to $ann2

=cut

sub template {
	my ( $self, $other ) = @_;
	
	# copy over the simple properties
	$log->debug("copying over simple properties");
	my %scalar_properties = __PACKAGE__->_scalar_properties;
	for my $prop ( keys %scalar_properties ) {
		my $val = $self->$prop;
		$other->$prop($val);
	}
	
	# copy over the list properties
	$log->debug("copying over list properties");
	my %list_properties = __PACKAGE__->_list_properties;
	for my $prop ( keys %list_properties ) {
		my @values = $self->$prop;
		$other->$prop(@values);
	}
	
	# copy over the layer properties
	$log->debug("copying over layer properties");
	my %layer_properties = __PACKAGE__->_layer_properties;
	for my $prop ( keys %layer_properties ) {
		for my $i ( 0 .. $self->num_layers - 1 ) {
			for my $j ( 0 .. $self->layer_num_neurons($i) - 1 ) {
				my $val = $self->$prop($i,$j);
				$other->$prop($i,$j,$val);			
			}
		}
	}
	return $self;
}

=item recombine

Recombines (exchanges) properties between the two objects at the provided rate, e.g.
$ann1->recombine($ann2,0.5) means that on average half of the object properties are
exchanged between $ann1 and $ann2

=cut

sub recombine {
	my ( $self, $other, $rr ) = @_;
	
	# recombine the simple properties
	my %scalar_properties = __PACKAGE__->_scalar_properties;
	for my $prop ( keys %scalar_properties ) {
		if ( rand(1) < $rr ) {			
			my $vals = $self->$prop;
			my $valo = $other->$prop;
			$other->$prop($vals);
			$self->$prop($valo);
		}
	}
	
	# copy over the list properties
	my %list_properties = __PACKAGE__->_list_properties;
	for my $prop ( keys %list_properties ) {
		if ( rand(1) < $rr ) {
			my @values = $self->$prop;
			my @valueo = $other->$prop;
			$other->$prop(@values);
			$self->$prop(@valueo);
		}
	}
	
	# copy over the layer properties
	my %layer_properties = __PACKAGE__->_layer_properties;
	for my $prop ( keys %layer_properties ) {
		for my $i ( 0 .. $self->num_layers - 1 ) {
			for my $j ( 0 .. $self->layer_num_neurons($i) - 1 ) {
				my $val = $self->$prop($i,$j);
				$other->$prop($i,$j,$val);			
			}
		}
	}
	return $self;	
}

=item mutate

Mutates the object by the provided mutation rate

=cut

sub mutate {
	my ( $self, $mu ) = @_;
	$log->debug("going to mutate at rate $mu");
	
	# mutate the simple properties
	$log->debug("mutating scalar properties");
	my %scalar_properties = __PACKAGE__->_scalar_properties;
	for my $prop ( keys %scalar_properties ) {
		my $handler = $scalar_properties{$prop};
		my $val = $self->$prop;
		if ( ref $handler ) {
			$self->$prop( $handler->($val,$mu) );
		}

lib/AI/FANN/Evolving.pm  view on Meta::CPAN

			}
		}
	}
	return $self;
}

sub _mutate_double {
	my ( $value, $mu ) = @_;
	my $scale = 1 + ( rand( 2 * $mu ) - $mu );
	return $value * $scale;
}

sub _mutate_int {
	my ( $value, $mu ) = @_;
	if ( rand(1) < $mu ) {
		my $inc = ( int(rand(2)) * 2 ) - 1;
		while( ( $value < 0 ) xor ( ( $value + $inc ) < 0 ) ) {
			$inc = ( int(rand(2)) * 2 ) - 1;
		}
		return $value + $inc;
	}
	return $value;
}

sub _mutate_enum {
	my ( $enum_name, $value, $mu ) = @_;
	if ( rand(1) < $mu ) {
		my ($newval) = shuffle grep { $_ != $value } values %{ $enum{$enum_name} };
		$value = $newval if defined $newval;
	}
	return $value;
}

sub _list_properties {
	(
#		cascade_activation_functions   => 'activationfunc',
		cascade_activation_steepnesses => \&_mutate_double,
	)
}

sub _layer_properties {
	(
#		neuron_activation_function  => 'activationfunc',
#		neuron_activation_steepness => \&_mutate_double,
	)
}

sub _scalar_properties {
	(
		training_algorithm                   => 'train',
		train_error_function                 => 'errorfunc',
		train_stop_function                  => 'stopfunc',
		learning_rate                        => \&_mutate_double,
		learning_momentum                    => \&_mutate_double,
		quickprop_decay                      => \&_mutate_double,
		quickprop_mu                         => \&_mutate_double,
		rprop_increase_factor                => \&_mutate_double,
		rprop_decrease_factor                => \&_mutate_double,
		rprop_delta_min                      => \&_mutate_double,
		rprop_delta_max                      => \&_mutate_double,
		cascade_output_change_fraction       => \&_mutate_double,
		cascade_candidate_change_fraction    => \&_mutate_double,
		cascade_output_stagnation_epochs     => \&_mutate_int,
		cascade_candidate_stagnation_epochs  => \&_mutate_int,
		cascade_max_out_epochs               => \&_mutate_int,
		cascade_max_cand_epochs              => \&_mutate_int,
		cascade_num_candidate_groups         => \&_mutate_int,
		bit_fail_limit                       => \&_mutate_double, # 'fann_type',
		cascade_weight_multiplier            => \&_mutate_double, # 'fann_type',
		cascade_candidate_limit              => \&_mutate_double, # 'fann_type',
	)
}

=item defaults

Getter/setter to influence default ANN configuration

=cut

sub defaults {
	my $self = shift;
	my %args = @_;
	for my $key ( keys %args ) {
		$log->info("setting $key to $args{$key}");
		if ( $key eq 'activation_function' ) {
			$args{$key} = $constant{$args{$key}};
		}
		$default{$key} = $args{$key};
	}
	return %default;
}

sub _init {
	my $self = shift;
	my %args = @_;
	for ( qw(error epochs train_type epoch_printfreq neuron_printfreq neurons activation_function) ) {
		$self->{$_} = $args{$_} // $default{$_};
	}
	return $self;
}

=item clone

Clones the object

=cut

sub clone {
	my $self = shift;
	$log->debug("cloning...");
	
	# we delete the reference here so we can use 
	# Algorithm::Genetic::Diploid::Base's cloning method, which
	# dumps and loads from YAML. This wouldn't work if the 
	# reference is still attached because it cannot be 
	# stringified, being an XS data structure
	my $ann = delete $self->{'ann'};
	my $clone = $self->SUPER::clone;
	
	# clone the ANN by writing it to a temp file in "FANN/FLO"
	# format and reading that back in, then delete the file
	my ( $fh, $file ) = tempfile();