AI-FANN-Evolving
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
{
"abstract" : "artificial neural network that evolves",
"author" : [
"Rutger Vos <rutger.vos@naturalis.nl>"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 6.8, CPAN::Meta::Converter version 2.132830",
"license" : [
"unknown"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "AI-FANN-Evolving",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"AI::FANN" : "0",
"Algorithm::Genetic::Diploid" : "0"
}
}
},
"release_status" : "stable",
"version" : "0.4"
}
---
abstract: 'artificial neural network that evolves'
author:
- 'Rutger Vos <rutger.vos@naturalis.nl>'
build_requires:
ExtUtils::MakeMaker: 0
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 6.8, CPAN::Meta::Converter version 2.132830'
license: unknown
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: AI-FANN-Evolving
no_index:
directory:
- t
- inc
requires:
AI::FANN: 0
Algorithm::Genetic::Diploid: 0
version: 0.4
MYMETA.json view on Meta::CPAN
{
"abstract" : "artificial neural network that evolves",
"author" : [
"Rutger Vos <rutger.vos@naturalis.nl>"
],
"dynamic_config" : 0,
"generated_by" : "ExtUtils::MakeMaker version 6.8, CPAN::Meta::Converter version 2.132830",
"license" : [
"unknown"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "AI-FANN-Evolving",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"AI::FANN" : "0",
"Algorithm::Genetic::Diploid" : "0"
}
}
},
"release_status" : "stable",
"version" : "0.4"
}
---
abstract: 'artificial neural network that evolves'
author:
- 'Rutger Vos <rutger.vos@naturalis.nl>'
build_requires:
ExtUtils::MakeMaker: 0
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 0
generated_by: 'ExtUtils::MakeMaker version 6.8, CPAN::Meta::Converter version 2.132830'
license: unknown
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: AI-FANN-Evolving
no_index:
directory:
- t
- inc
requires:
AI::FANN: 0
Algorithm::Genetic::Diploid: 0
version: 0.4
Makefile.PL view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
use ExtUtils::MakeMaker;
WriteMakefile(
'NAME' => 'AI::FANN::Evolving',
'ABSTRACT_FROM' => 'lib/AI/FANN/Evolving.pm',
'VERSION_FROM' => 'lib/AI/FANN/Evolving.pm',
'EXE_FILES' => [ 'script/aivolver' ],
'AUTHOR' => 'Rutger Vos <rutger.vos@naturalis.nl>',
'PREREQ_PM' => {
'AI::FANN' => 0,
'Algorithm::Genetic::Diploid' => 0,
},
);
lib/AI/FANN/Evolving.pm view on Meta::CPAN
use AI::FANN::Evolving::Experiment;
use AI::FANN::Evolving::Factory;
use Algorithm::Genetic::Diploid;
use base qw'Algorithm::Genetic::Diploid::Base';
our $VERSION = '0.4';
our $AUTOLOAD;
my $log = __PACKAGE__->logger;
my %enum = (
'train' => {
# 'FANN_TRAIN_INCREMENTAL' => FANN_TRAIN_INCREMENTAL, # only want batch training
'FANN_TRAIN_BATCH' => FANN_TRAIN_BATCH,
'FANN_TRAIN_RPROP' => FANN_TRAIN_RPROP,
'FANN_TRAIN_QUICKPROP' => FANN_TRAIN_QUICKPROP,
},
'activationfunc' => {
'FANN_LINEAR' => FANN_LINEAR,
# 'FANN_THRESHOLD' => FANN_THRESHOLD, # can not be used during training
# 'FANN_THRESHOLD_SYMMETRIC' => FANN_THRESHOLD_SYMMETRIC, # can not be used during training
# 'FANN_SIGMOID' => FANN_SIGMOID, # range is between 0 and 1
# 'FANN_SIGMOID_STEPWISE' => FANN_SIGMOID_STEPWISE, # range is between 0 and 1
'FANN_SIGMOID_SYMMETRIC' => FANN_SIGMOID_SYMMETRIC,
'FANN_SIGMOID_SYMMETRIC_STEPWISE' => FANN_SIGMOID_SYMMETRIC_STEPWISE,
# 'FANN_GAUSSIAN' => FANN_GAUSSIAN, # range is between 0 and 1
'FANN_GAUSSIAN_SYMMETRIC' => FANN_GAUSSIAN_SYMMETRIC,
'FANN_GAUSSIAN_STEPWISE' => FANN_GAUSSIAN_STEPWISE,
# 'FANN_ELLIOT' => FANN_ELLIOT, # range is between 0 and 1
'FANN_ELLIOT_SYMMETRIC' => FANN_ELLIOT_SYMMETRIC,
# 'FANN_LINEAR_PIECE' => FANN_LINEAR_PIECE, # range is between 0 and 1
'FANN_LINEAR_PIECE_SYMMETRIC' => FANN_LINEAR_PIECE_SYMMETRIC,
'FANN_SIN_SYMMETRIC' => FANN_SIN_SYMMETRIC,
'FANN_COS_SYMMETRIC' => FANN_COS_SYMMETRIC,
# 'FANN_SIN' => FANN_SIN, # range is between 0 and 1
# 'FANN_COS' => FANN_COS, # range is between 0 and 1
},
'errorfunc' => {
'FANN_ERRORFUNC_LINEAR' => FANN_ERRORFUNC_LINEAR,
'FANN_ERRORFUNC_TANH' => FANN_ERRORFUNC_TANH,
},
'stopfunc' => {
'FANN_STOPFUNC_MSE' => FANN_STOPFUNC_MSE,
# 'FANN_STOPFUNC_BIT' => FANN_STOPFUNC_BIT,
}
);
my %constant;
for my $hashref ( values %enum ) {
while( my ( $k, $v ) = each %{ $hashref } ) {
$constant{$k} = $v;
}
}
my %default = (
'error' => 0.0001,
'epochs' => 5000,
'train_type' => 'ordinary',
'epoch_printfreq' => 100,
'neuron_printfreq' => 0,
'neurons' => 15,
'activation_function' => FANN_SIGMOID_SYMMETRIC,
);
=head1 NAME
AI::FANN::Evolving - artificial neural network that evolves
=head1 METHODS
=over
=item new
Constructor requires 'file', or 'data' and 'neurons' arguments. Optionally takes
'connection_rate' argument for sparse topologies. Returns a wrapper around L<AI::FANN>.
=cut
sub new {
my $class = shift;
my %args = @_;
my $self = {};
bless $self, $class;
$self->_init(%args);
# de-serialize from a file
if ( my $file = $args{'file'} ) {
$self->{'ann'} = AI::FANN->new_from_file($file);
$log->debug("instantiating from file $file");
return $self;
}
# build new topology from input data
elsif ( my $data = $args{'data'} ) {
$log->debug("instantiating from data $data");
$data = $data->to_fann if $data->isa('AI::FANN::Evolving::TrainData');
# prepare arguments
my $neurons = $args{'neurons'} || ( $data->num_inputs + 1 );
my @sizes = (
$data->num_inputs,
$neurons,
$data->num_outputs
);
# build topology
if ( $args{'connection_rate'} ) {
$self->{'ann'} = AI::FANN->new_sparse( $args{'connection_rate'}, @sizes );
}
else {
$self->{'ann'} = AI::FANN->new_standard( @sizes );
}
# finalize the instance
return $self;
}
# build new ANN using argument as a template
elsif ( my $ann = $args{'ann'} ) {
$log->debug("instantiating from template $ann");
# copy the wrapper properties
%{ $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) );
}
else {
$self->$prop( _mutate_enum($handler,$val,$mu) );
}
}
# mutate the list properties
$log->debug("mutating list properties");
my %list_properties = __PACKAGE__->_list_properties;
for my $prop ( keys %list_properties ) {
my $handler = $list_properties{$prop};
my @values = $self->$prop;
if ( ref $handler ) {
$self->$prop( map { $handler->($_,$mu) } @values );
}
else {
$self->$prop( map { _mutate_enum($handler,$_,$mu) } @values );
}
}
# mutate the layer properties
$log->debug("mutating layer properties");
my %layer_properties = __PACKAGE__->_layer_properties;
for my $prop ( keys %layer_properties ) {
my $handler = $layer_properties{$prop};
for my $i ( 1 .. $self->num_layers ) {
for my $j ( 1 .. $self->layer_num_neurons($i) ) {
my $val = $self->$prop($i,$j);
if ( ref $handler ) {
$self->$prop( $handler->($val,$mu) );
}
else {
$self->$prop( _mutate_enum($handler,$val,$mu) );
}
}
}
}
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();
close $fh;
$ann->save($file);
$clone->{'ann'} = __PACKAGE__->new_from_file($file);
unlink $file;
# now re-attach the original ANN to the invocant
$self->{'ann'} = $ann;
return $clone;
}
=item train
Trains the AI on the provided data object
=cut
sub train {
my ( $self, $data ) = @_;
if ( $self->train_type eq 'cascade' ) {
$log->debug("cascade training");
# set learning curve
$self->cascade_activation_functions( $self->activation_function );
# train
$self->{'ann'}->cascadetrain_on_data(
$data,
$self->neurons,
$self->neuron_printfreq,
$self->error,
);
}
else {
$log->debug("normal training");
# set learning curves
$self->hidden_activation_function( $self->activation_function );
$self->output_activation_function( $self->activation_function );
# train
$self->{'ann'}->train_on_data(
$data,
$self->epochs,
$self->epoch_printfreq,
$self->error,
);
}
}
=item enum_properties
Returns a hash whose keys are names of enums and values the possible states for the
enum
=cut
=item error
Getter/setter for the error rate. Default is 0.0001
=cut
sub error {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting error threshold to $value");
return $self->{'error'} = $value;
}
else {
$log->debug("getting error threshold");
return $self->{'error'};
}
}
=item epochs
Getter/setter for the number of training epochs, default is 500000
=cut
sub epochs {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting training epochs to $value");
return $self->{'epochs'} = $value;
}
else {
$log->debug("getting training epochs");
return $self->{'epochs'};
}
}
=item epoch_printfreq
Getter/setter for the number of epochs after which progress is printed. default is 1000
=cut
sub epoch_printfreq {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting epoch printfreq to $value");
return $self->{'epoch_printfreq'} = $value;
}
else {
$log->debug("getting epoch printfreq");
return $self->{'epoch_printfreq'}
}
}
=item neurons
Getter/setter for the number of neurons. Default is 15
=cut
sub neurons {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting neurons to $value");
return $self->{'neurons'} = $value;
}
else {
$log->debug("getting neurons");
return $self->{'neurons'};
}
}
=item neuron_printfreq
Getter/setter for the number of cascading neurons after which progress is printed.
default is 10
=cut
sub neuron_printfreq {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting neuron printfreq to $value");
return $self->{'neuron_printfreq'} = $value;
}
else {
$log->debug("getting neuron printfreq");
return $self->{'neuron_printfreq'};
}
}
=item train_type
Getter/setter for the training type: 'cascade' or 'ordinary'. Default is ordinary
=cut
sub train_type {
my $self = shift;
if ( @_ ) {
my $value = lc shift;
$log->debug("setting train type to $value");
return $self->{'train_type'} = $value;
}
else {
$log->debug("getting train type");
return $self->{'train_type'};
}
}
=item activation_function
Getter/setter for the function that maps inputs to outputs. default is
FANN_SIGMOID_SYMMETRIC
=back
=cut
sub activation_function {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting activation function to $value");
return $self->{'activation_function'} = $value;
}
else {
$log->debug("getting activation function");
return $self->{'activation_function'};
}
}
# this is here so that we can trap method calls that need to be
# delegated to the FANN object. at this point we're not even
# going to care whether the FANN object implements these methods:
# if it doesn't we get the normal error for unknown methods, which
# the user then will have to resolve.
sub AUTOLOAD {
my $self = shift;
my $method = $AUTOLOAD;
$method =~ s/.+://;
# ignore all caps methods
if ( $method !~ /^[A-Z]+$/ ) {
# determine whether to invoke on an object or a package
my $invocant;
if ( ref $self ) {
$invocant = $self->{'ann'};
}
else {
$invocant = 'AI::FANN';
}
# determine whether to pass in arguments
if ( @_ ) {
my $arg = shift;
$arg = $constant{$arg} if exists $constant{$arg};
return $invocant->$method($arg);
}
else {
return $invocant->$method;
}
}
}
1;
lib/AI/FANN/Evolving/Chromosome.pm view on Meta::CPAN
=over
=item recombine
Recombines properties of the AI during meiosis in proportion to the crossover_rate
=cut
sub recombine {
$log->debug("recombining chromosomes");
# get the genes and columns for the two chromosomes
my ( $chr1, $chr2 ) = @_;
my ( $gen1 ) = map { $_->mutate } $chr1->genes;
my ( $gen2 ) = map { $_->mutate } $chr2->genes;
my ( $ann1, $ann2 ) = ( $gen1->ann, $gen2->ann );
$ann1->recombine($ann2,$chr1->experiment->crossover_rate);
# assign the genes to the chromosomes (this because they are clones
# so we can't use the old object reference)
$chr1->genes($gen1);
$chr2->genes($gen2);
}
=item clone
Clones the object
=back
=cut
sub clone {
my $self = shift;
my @genes = $self->genes;
my $self_clone = $self->SUPER::clone;
$self_clone->genes( map { $_->clone } @genes );
return $self_clone;
}
1;
lib/AI/FANN/Evolving/Experiment.pm view on Meta::CPAN
=item workdir
Getter/Setter for the workdir where L<AI::FANN> artificial neural networks will be
written during the experiment. The files will be named after the ANN's error, which
needs to be minimized.
=cut
sub workdir {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->info("assigning new workdir $value");
$self->{'workdir'} = $value;
}
else {
$log->debug("retrieving workdir");
}
return $self->{'workdir'};
}
=item traindata
Getter/setter for the L<AI::FANN::TrainData> object.
=cut
sub traindata {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->info("assigning new traindata $value");
$self->{'traindata'} = $value;
}
else {
$log->debug("retrieving traindata");
}
return $self->{'traindata'};
}
=item run
Runs the experiment!
=cut
sub run {
my $self = shift;
my $log = $self->logger;
$log->info("going to run experiment");
my @results;
for my $i ( 1 .. $self->ngens ) {
# modify workdir
my $wd = $self->{'workdir'};
$wd =~ s/\d+$/$i/;
$self->{'workdir'} = $wd;
mkdir $wd;
my $optimum = $self->optimum($i);
$log->debug("optimum at generation $i is $optimum");
my ( $fittest, $fitness ) = $self->population->turnover($i,$self->env,$optimum);
push @results, [ $fittest, $fitness ];
}
my ( $fittest, $fitness ) = map { @{ $_ } } sort { $a->[1] <=> $b->[1] } @results;
return $fittest, $fitness;
}
=item optimum
The optimal fitness is zero error in the ANN's classification. This method returns
that value: 0.
=cut
sub optimum { 0 }
sub _sign {
my ( $obs, $exp ) = @_;
my $fitness = 0;
for my $i ( 0 .. $#{ $obs } ) {
$fitness += ( ( $obs->[$i] > 0 ) xor ( $exp->[$i] > 0 ) );
}
return $fitness / scalar(@{$obs});
}
sub _mse {
my ( $obs, $exp ) = @_;
my $fitness = 0;
for my $i ( 0 .. $#{ $obs } ) {
$fitness += ( ( (1+$obs->[$i]) - (1+$exp->[$i]) ) ** 2 );
}
return $fitness / scalar(@{$obs});
}
=item error_func
Returns a function to compute the error. Given an argument, the following can happen:
'sign' => error is the average number of times observed and expected have different signs
'mse' => error is the mean squared difference between observed and expected
CODE => error function is the provided code reference
=back
=cut
sub error_func {
my $self = shift;
# process the argument
if ( @_ ) {
my $arg = shift;
if ( ref $arg eq 'CODE' ) {
$self->{'error_func'} = $arg;
$log->info("using custom error function");
}
elsif ( $arg eq 'sign' ) {
$self->{'error_func'} = \&_sign;
$log->info("using sign test error function");
}
elsif ( $arg eq 'mse' ) {
$self->{'error_func'} = \&_mse;
$log->info("using MSE error function");
}
else {
$log->warn("don't understand error func '$arg'");
}
}
# map the constructor-supplied argument
if ( $self->{'error_func'} and $self->{'error_func'} eq 'sign' ) {
$self->{'error_func'} = \&_sign;
$log->info("using error function 'sign'");
}
elsif ( $self->{'error_func'} and $self->{'error_func'} eq 'mse' ) {
$self->{'error_func'} = \&_mse;
$log->info("using error function 'mse'");
}
return $self->{'error_func'} || \&_mse;
}
1;
lib/AI/FANN/Evolving/Factory.pm view on Meta::CPAN
package AI::FANN::Evolving::Factory;
use strict;
use Algorithm::Genetic::Diploid;
use base 'Algorithm::Genetic::Diploid::Factory';
our $AUTOLOAD;
my %defaults = (
'experiment' => 'AI::FANN::Evolving::Experiment',
'chromosome' => 'AI::FANN::Evolving::Chromosome',
'gene' => 'AI::FANN::Evolving::Gene',
'traindata' => 'AI::FANN::Evolving::TrainData',
);
=head1 NAME
AI::FANN::Evolving::Factory - creator of objects
=head1 METHODS
=over
lib/AI/FANN/Evolving/Gene.pm view on Meta::CPAN
=over
=item new
Constructor is passed named arguments. Instantiates a trained L<AI::FANN::Evolving> ANN
=cut
sub new {
# initialize self up the inheritance tree
my $self = shift->SUPER::new(@_);
# instantiate and train the FANN object
my $traindata = $self->experiment->traindata;
$self->ann( AI::FANN::Evolving->new( 'data' => $traindata ) );
return $self;
}
=item ann
Getter/setter for an L<AI::FANN::Evolving> ANN
=cut
sub ann {
my $self = shift;
if ( @_ ) {
my $ann = shift;
$log->debug("setting ANN $ann");
return $self->{'ann'} = $ann;
}
else {
$log->debug("getting ANN");
return $self->{'ann'};
}
}
=item make_function
Returns a code reference to the fitness function, which when executed returns a fitness
value and writes the corresponding ANN to file
=cut
sub make_function {
my $self = shift;
my $ann = $self->ann;
my $error_func = $self->experiment->error_func;
$log->debug("making fitness function");
# build the fitness function
return sub {
# train the AI
$ann->train( $self->experiment->traindata );
# isa TrainingData object, this is what we need to use
# to make our prognostications. It is a different data
# set (out of sample) than the TrainingData object that
# the AI was trained on.
my $env = shift;
# this is a number which we try to keep as near to zero
# as possible
my $fitness = 0;
# iterate over the list of input/output pairs
for my $i ( 0 .. ( $env->length - 1 ) ) {
my ( $input, $expected ) = $env->data($i);
my $observed = $ann->run($input);
use Data::Dumper;
$log->debug("Observed: ".Dumper($observed));
$log->debug("Expected: ".Dumper($expected));
# invoke the error_func provided by the experiment
$fitness += $error_func->($observed,$expected);
}
$fitness /= $env->length;
# store result
$self->{'fitness'} = $fitness;
# store the AI
my $outfile = $self->experiment->workdir . "/${fitness}.ann";
$self->ann->save($outfile);
return $self->{'fitness'};
}
}
=item fitness
Stores the fitness value after expressing the fitness function
=cut
sub fitness { shift->{'fitness'} }
=item clone
Clones the object
=cut
sub clone {
my $self = shift;
my $ann = delete $self->{'ann'};
my $ann_clone = $ann->clone;
my $self_clone = $self->SUPER::clone;
$self_clone->ann( $ann_clone );
$self->ann( $ann );
return $self_clone;
}
=item mutate
Mutates the ANN by stochastically altering its properties in proportion to
the mutation_rate
=back
=cut
sub mutate {
my $self = shift;
# probably 0.05
my $mu = $self->experiment->mutation_rate;
# make a clone, whose untrained ANN properties are mutated
my $self_clone = $self->clone;
my $ann = AI::FANN::Evolving->new( 'ann' => $self->ann );
$ann->mutate($mu);
$self_clone->ann($ann);
return $self_clone;
}
1;
lib/AI/FANN/Evolving/TrainData.pm view on Meta::CPAN
=over
=item new
Constructor takes named arguments. By default, ignores column
named ID and considers column named CLASS as classifier.
=cut
sub new {
my $self = shift->SUPER::new(
'ignore' => [ 'ID' ],
'dependent' => [ 'CLASS' ],
'header' => {},
'table' => [],
@_
);
my %args = @_;
$self->read_data($args{'file'}) if $args{'file'};
$self->trim_data if $args{'trim'};
return $self;
}
=item ignore_columns
Getter/setter for column names to ignore in the train data structure.
For example: an identifier columns named 'ID'
=cut
sub ignore_columns {
my $self = shift;
$self->{'ignore'} = \@_ if @_;
return @{ $self->{'ignore'} };
}
=item dependent_columns
Getter/setter for column name(s) of the output value(s).
=cut
sub dependent_columns {
my $self = shift;
$self->{'dependent'} = \@_ if @_;
return @{ $self->{'dependent'} };
}
=item predictor_columns
Getter for column name(s) of input value(s)
=cut
sub predictor_columns {
my $self = shift;
my @others = ( $self->ignore_columns, $self->dependent_columns );
my %skip = map { $_ => 1 } @others;
return grep { ! $skip{$_} } keys %{ $self->{'header'} };
}
=item predictor_data
Getter for rows of input values
=cut
sub predictor_data {
my ( $self, %args ) = @_;
my $i = $args{'row'};
my @cols = $args{'cols'} ? @{ $args{'cols'} } : $self->predictor_columns;
# build hash of indices to keep
my %keep = map { $self->{'header'}->{$_} => 1 } @cols;
# only return a single row
if ( defined $i ) {
my @pred;
for my $j ( 0 .. $#{ $self->{'table'}->[$i] } ) {
push @pred, $self->{'table'}->[$i]->[$j] if $keep{$j};
}
return \@pred;
}
else {
my @preds;
my $max = $self->size - 1;
for my $j ( 0 .. $max ) {
push @preds, $self->predictor_data( 'row' => $j, 'cols' => \@cols);
}
return @preds;
}
}
=item dependent_data
Getter for dependent (classifier) data
=cut
sub dependent_data {
my ( $self, $i ) = @_;
my @dc = map { $self->{'header'}->{$_} } $self->dependent_columns;
if ( defined $i ) {
return [ map { $self->{'table'}->[$i]->[$_] } @dc ];
}
else {
my @dep;
for my $j ( 0 .. $self->size - 1 ) {
push @dep, $self->dependent_data($j);
}
return @dep;
}
}
=item read_data
Reads provided input file
=cut
sub read_data {
my ( $self, $file ) = @_; # file is tab-delimited
$log->debug("reading data from file $file");
open my $fh, '<', $file or die "Can't open $file: $!";
my ( %header, @table );
while(<$fh>) {
chomp;
next if /^\s*$/;
my @fields = split /\t/, $_;
if ( not %header ) {
my $i = 0;
%header = map { $_ => $i++ } @fields;
}
else {
push @table, \@fields;
}
}
$self->{'header'} = \%header;
$self->{'table'} = \@table;
return $self;
}
=item write_data
Writes to provided output file
=cut
sub write_data {
my ( $self, $file ) = @_;
# use file or STDOUT
my $fh;
if ( $file ) {
open $fh, '>', $file or die "Can't write to $file: $!";
$log->info("writing data to $file");
}
else {
$fh = \*STDOUT;
$log->info("writing data to STDOUT");
}
# print header
my $h = $self->{'header'};
print $fh join "\t", sort { $h->{$a} <=> $h->{$b} } keys %{ $h };
print $fh "\n";
# print rows
for my $row ( @{ $self->{'table'} } ) {
print $fh join "\t", @{ $row };
print $fh "\n";
}
}
=item trim_data
Trims sparse rows with missing values
=cut
sub trim_data {
my $self = shift;
my @trimmed;
ROW: for my $row ( @{ $self->{'table'} } ) {
next ROW if grep { not defined $_ } @{ $row };
push @trimmed, $row;
}
my $num = $self->{'size'} - scalar @trimmed;
$log->info("removed $num incomplete rows");
$self->{'table'} = \@trimmed;
}
=item sample_data
Sample a fraction of the data
=cut
sub sample_data {
my $self = shift;
my $sample = shift || 0.5;
my $clone1 = $self->clone;
my $clone2 = $self->clone;
my $size = $self->size;
my @sample;
$clone2->{'table'} = \@sample;
while( scalar(@sample) < int( $size * $sample ) ) {
my @shuffled = shuffle( @{ $clone1->{'table'} } );
push @sample, shift @shuffled;
$clone1->{'table'} = \@shuffled;
}
return $clone2, $clone1;
}
=item partition_data
Creates two clones that partition the data according to the provided ratio.
=cut
sub partition_data {
my $self = shift;
my $sample = shift || 0.5;
my $clone1 = $self->clone;
my $clone2 = $self->clone;
my $remain = 1 - $sample;
$log->info("going to partition into $sample : $remain");
# compute number of different dependent patterns and ratios of each
my @dependents = $self->dependent_data;
my %seen;
for my $dep ( @dependents ) {
my $key = join '/', @{ $dep };
$seen{$key}++;
}
# adjust counts to sample size
for my $key ( keys %seen ) {
$log->debug("counts: $key => $seen{$key}");
$seen{$key} = int( $seen{$key} * $sample );
$log->debug("rescaled: $key => $seen{$key}");
}
# start the sampling
my @dc = map { $self->{'header'}->{$_} } $self->dependent_columns;
my @new_table; # we will populate this
my @table = @{ $clone1->{'table'} }; # work on cloned instance
# as long as there is still sampling to do
SAMPLE: while( grep { !!$_ } values %seen ) {
for my $i ( 0 .. $#table ) {
my @r = @{ $table[$i] };
my $key = join '/', @r[@dc];
if ( $seen{$key} ) {
my $rand = rand(1);
if ( $rand < $sample ) {
push @new_table, \@r;
splice @table, $i, 1;
$seen{$key}--;
$log->debug("still to go for $key: $seen{$key}");
next SAMPLE;
}
}
}
}
$clone2->{'table'} = \@new_table;
$clone1->{'table'} = \@table;
return $clone2, $clone1;
}
=item size
Returns the number of data records
=cut
sub size { scalar @{ shift->{'table'} } }
=item to_fann
Packs data into an L<AI::FANN> TrainData structure
=cut
sub to_fann {
$log->debug("encoding data as FANN struct");
my $self = shift;
my @cols = @_ ? @_ : $self->predictor_columns;
my @deps = $self->dependent_data;
my @pred = $self->predictor_data( 'cols' => \@cols );
my @interdigitated;
for my $i ( 0 .. $#deps ) {
push @interdigitated, $pred[$i], $deps[$i];
}
return AI::FANN::TrainData->new(@interdigitated);
}
=back
=cut
1;
script/aivolver view on Meta::CPAN
my $verbosity = WARN; # log level
my $formatter = 'simple'; # log formatter
my %initialize; # settings to start the population
my %data; # train and test data files
my %experiment; # experiment settings
my %ann; # ANN settings
my $outfile;
# there are no arguments
if ( not @ARGV ) {
pod2usage( '-verbose' => 0 );
}
# first argument is a config file
if ( -e $ARGV[0] ) {
my $conf = shift;
my $yaml = LoadFile($conf);
$outfile = $yaml->{'outfile'} if defined $yaml->{'outfile'};
$verbosity = $yaml->{'verbosity'} if defined $yaml->{'verbosity'};
$formatter = $yaml->{'formatter'} if defined $yaml->{'formatter'};
%initialize = %{ $yaml->{'initialize'} } if defined $yaml->{'initialize'};
%data = %{ $yaml->{'data'} } if defined $yaml->{'data'};
%experiment = %{ $yaml->{'experiment'} } if defined $yaml->{'experiment'};
%ann = %{ $yaml->{'ann'} } if defined $yaml->{'ann'};
}
# process command line arguments
GetOptions(
'verbose+' => \$verbosity,
'formatter=s' => \$formatter,
'outfile=s' => \$outfile,
'initialize=s' => \%initialize,
'data=s' => \%data,
'experiment=s' => \%experiment,
'ann=s' => \%ann,
'help|?' => sub { pod2usage( '-verbose' => 1 ) },
'manual' => sub { pod2usage( '-verbose' => 2 ) },
);
# configure ANN
AI::FANN::Evolving->defaults(%ann);
# configure logger
my $log = Algorithm::Genetic::Diploid::Logger->new;
$log->level( 'level' => $verbosity );
$log->formatter( $formatter );
# read input data
my $deps = join ', ', @{ $data{'dependent'} };
my $ignore = join ', ', @{ $data{'ignore'} };
$log->info("going to read train data $data{file}, ignoring '$ignore', dependent columns are '$deps'");
my $inputdata = AI::FANN::Evolving::TrainData->new(
'file' => $data{'file'},
'dependent' => $data{'dependent'},
'ignore' => $data{'ignore'},
);
my ( $traindata, $testdata );
if ( $data{'type'} and lc $data{'type'} eq 'continuous' ) {
( $traindata, $testdata ) = $inputdata->sample_data( $data{'fraction'} );
}
else {
( $traindata, $testdata ) = $inputdata->partition_data( $data{'fraction'} );
}
$log->info("number of training data records: ".$traindata->size);
$log->info("number of test data records: ".$testdata->size);
# create first work dir
my $wd = delete $experiment{'workdir'};
make_path($wd);
$wd .= '/0';
# create the experiment
my $exp = AI::FANN::Evolving::Experiment->new(
'traindata' => $traindata->to_fann,
'env' => $testdata->to_fann,
'workdir' => $wd,
%experiment,
);
# initialize the experiment
$exp->initialize(%initialize);
# run!
my ( $fittest, $fitness ) = $exp->run();
$log->info("*** overall best fitness: $fitness");
my ($gene) = sort { $a->fitness <=> $b->fitness } map { $_->genes } $fittest->chromosomes;
$gene->ann->save($outfile);
#!/usr/bin/perl
use Test::More 'no_plan';
use strict;
use FindBin qw($Bin);
use File::Temp 'tempdir';
# attempt to load the classes of interest
BEGIN {
use_ok('AI::FANN::Evolving::Factory');
use_ok('AI::FANN::Evolving::TrainData');
use_ok('AI::FANN::Evolving');
use_ok('Algorithm::Genetic::Diploid::Logger');
}
# create and configure logger
my $log = new_ok('Algorithm::Genetic::Diploid::Logger');
$log->level( 'level' => 4 );
$log->formatter(sub{
my %args = @_;
if ( $args{'msg'} =~ /fittest at generation (\d+): (.+)/ ) {
my ( $gen, $fitness ) = ( $1, $2 );
ok( $fitness, "generation $gen/2, fitness: $fitness" );
}
return '';
});
# set quieter and quicker to give up
AI::FANN::Evolving->defaults( 'epoch_printfreq' => 0, 'epochs' => 200 );
# instantiate factory
my $fac = new_ok('AI::FANN::Evolving::Factory');
# prepare data
my $data = AI::FANN::Evolving::TrainData->new(
'file' => "$Bin/../examples/Cochlopetalum.tsv",
'ignore' => [ 'image' ],
'dependent' => [ 'C1', 'C2', 'C3', 'C4', 'C5' ],
);
my ( $test, $train ) = $data->partition_data( 0.5 );
# create the experiment
my $exp = $fac->create_experiment(
'workdir' => tempdir( 'CLEANUP' => 1 ),
'traindata' => $train->to_fann,
'factory' => $fac,
'env' => $test->to_fann,
'mutation_rate' => 0.1,
'ngens' => 2,
);
isa_ok( $exp, 'Algorithm::Genetic::Diploid::Experiment' );
# initialize the experiment
ok( $exp->initialize( 'individual_count' => 2 ), "initialized" );
# run!
my ( $fittest, $fitness ) = $exp->run();
isa_ok( $fittest, 'Algorithm::Genetic::Diploid::Individual' );
t/02-data.t view on Meta::CPAN
use FindBin qw($Bin);
use Test::More 'no_plan';
use AI::FANN::Evolving::TrainData;
use Algorithm::Genetic::Diploid::Logger ':levels';
use Data::Dumper;
# instantiate a data object
my $file = "$Bin/../examples/merged.tsv";
my $data = AI::FANN::Evolving::TrainData->new(
'file' => $file,
'ignore' => [ 'image' ],
'dependent' => [ 'C1', 'C2', 'C3', 'C4' ],
);
ok( $data, "instantiate" );
# partition the data
my ( $d1, $d2 ) = $data->partition_data(0.2);
ok( $data->size == $d1->size + $d2->size, "partition" );
# pack data as FANN struct
ok( $d1->to_fann, "packed d1" );
ok( $d2->to_fann, "packed d2" );
t/03-fann-wrapper.t view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
use Test::More 'no_plan';
BEGIN {
use_ok('AI::FANN::Evolving');
use_ok('AI::FANN::Evolving::TrainData');
}
##########################################################################################
# create a trivial data object:
my $data = AI::FANN::Evolving::TrainData->new(
'header' => {
'ID' => 0, # simple integer id for the records
's1' => 1, # state 1
's2' => 2, # state 2
'CLASS' => 3, # dependent 'xor' state
},
# this is the xor example from:
# http://search.cpan.org/~salva/AI-FANN-0.10/lib/AI/FANN.pm
'table' => [
[ 1, -1, -1, -1 ],
[ 2, -1, +1, +1 ],
[ 3, +1, -1, +1 ],
[ 4, +1, +1, -1 ],
],
);
ok( $data->size == 4, "instantiate data correctly" );
##########################################################################################
# train the FANN object on trivial data
my $ann = AI::FANN::Evolving->new( 'data' => $data, 'epoch_printfreq' => 0 );
$ann->train($data->to_fann);
# run the network
# this is the xor example from:
# http://search.cpan.org/~salva/AI-FANN-0.10/lib/AI/FANN.pm
my @result = ( -1, +1, +1, -1 );
my @input = ( [ -1, -1 ], [ -1, +1 ], [ +1, -1 ], [ +1, +1 ] );
for my $i ( 0 .. $#input ) {
my $output = $ann->run($input[$i]);
ok( ! ( $result[$i] < 0 xor $output->[0] < 0 ), "observed and expected signs match" );
}
t/perl-critic.t view on Meta::CPAN
use strict;
use warnings;
use File::Spec;
use Test::More;
use English qw'no_match_vars';
if ( not $ENV{'TEST_AUTHOR'} ) {
my $msg = 'env var TEST_AUTHOR not set';
plan( 'skip_all' => $msg );
}
eval { require Test::Perl::Critic; };
if ($EVAL_ERROR) {
my $msg = 'Test::Perl::Critic required to criticise code';
plan( 'skip_all' => $msg );
}
my $rcfile = File::Spec->catfile( 't', 'perlcriticrc' );
Test::Perl::Critic->import( '-profile' => $rcfile );
Test::Perl::Critic::all_critic_ok();
t/pod-coverage.t view on Meta::CPAN
use Test::More;
plan skip_all => 'env var TEST_AUTHOR not set' if not $ENV{'TEST_AUTHOR'};
eval "use Test::Pod::Coverage 1.04";
plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage"
if $@;
all_pod_coverage_ok();
view release on metacpan - search on metacpan
( run in 0.749 second using v1.00-cache-2.02-grep-82fe00e-cpan-2c419f77a38b )