AI-CBR
view release on metacpan or search on metacpan
blib*
Makefile
Makefile.old
Build
_build*
pm_to_blib*
*.tar.gz
.lwpcookies
AI-CBR-*
cover_db
use strict;
use warnings;
use Module::Build;
my $builder = Module::Build->new(
module_name => 'AI::CBR',
license => 'perl',
dist_author => 'Darko Obradovic <dobradovic@gmx.de>',
dist_version_from => 'lib/AI/CBR.pm',
build_requires => {
'Test::More' => 0,
},
add_to_cleanup => [ 'AI-CBR-*' ],
create_makefile_pl => 'traditional',
);
$builder->create_build_script();
Revision history for AI-CBR
0.02 July 31, 2009
Some documentation fixes.
0.01 July 30, 2009
First version, released on an unsuspecting world.
.cvsignore
Build.PL
Changes
lib/AI/CBR.pm
lib/AI/CBR/Case.pm
lib/AI/CBR/Case/Compound.pm
lib/AI/CBR/Retrieval.pm
lib/AI/CBR/Sim.pm
Makefile.PL
MANIFEST
META.yml
README
t/00-load.t
t/01-sim.t
t/02-case.t
t/03-retrieval.t
t/04-case-compound.t
t/boilerplate.t
t/pod-coverage.t
t/pod.t
---
name: AI-CBR
version: 0.02
author:
- 'Darko Obradovic <dobradovic@gmx.de>'
abstract: Framework for Case-Based Reasoning
license: perl
resources:
license: http://dev.perl.org/licenses/
build_requires:
Test::More: 0
provides:
AI::CBR:
file: lib/AI/CBR.pm
version: 0.02
AI::CBR::Case:
file: lib/AI/CBR/Case.pm
AI::CBR::Case::Compound:
file: lib/AI/CBR/Case/Compound.pm
AI::CBR::Retrieval:
file: lib/AI/CBR/Retrieval.pm
AI::CBR::Sim:
file: lib/AI/CBR/Sim.pm
generated_by: Module::Build version 0.2808
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.2.html
version: 1.2
Makefile.PL view on Meta::CPAN
# Note: this file was auto-generated by Module::Build::Compat version 0.03
use ExtUtils::MakeMaker;
WriteMakefile
(
'NAME' => 'AI::CBR',
'VERSION_FROM' => 'lib/AI/CBR.pm',
'PREREQ_PM' => {
'Test::More' => '0'
},
'INSTALLDIRS' => 'site',
'EXE_FILES' => [],
'PL_FILES' => {}
)
;
AI-CBR
The README is used to introduce the module and provide instructions on
how to install the module, any machine dependencies it may have (for
example C compilers and installed libraries) and any other information
that should be provided before the module is installed.
A README file is required for CPAN modules since CPAN extracts the README
file from a module distribution so that people browsing the archive
can use it to get an idea of the module's uses. It is usually a good idea
to provide version information here so that people can decide whether
fixes for the module are worth downloading.
INSTALLATION
To install this module, run the following commands:
perl Makefile.PL
make
make test
make install
Alternatively, to install with Module::Build, you can use the following commands:
perl Build.PL
./Build
./Build test
./Build install
SUPPORT AND DOCUMENTATION
After installing, you can find documentation for this module with the
perldoc command.
perldoc AI::CBR::Case
You can also look for information at:
RT, CPAN's request tracker
http://rt.cpan.org/NoAuth/Bugs.html?Dist=AI-CBR
AnnoCPAN, Annotated CPAN documentation
http://annocpan.org/dist/AI-CBR
CPAN Ratings
http://cpanratings.perl.org/d/AI-CBR
Search CPAN
http://search.cpan.org/dist/AI-CBR
COPYRIGHT AND LICENCE
Copyright (C) 2009 Darko Obradovic
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
lib/AI/CBR.pm view on Meta::CPAN
package AI::CBR;
use warnings;
use strict;
=head1 NAME
AI::CBR - Framework for Case-Based Reasoning
=head1 VERSION
Version 0.02
=cut
our $VERSION = '0.02';
=head1 SYNOPSIS
use AI::CBR::Sim qw(sim_eq ...);
use AI::CBR::Case;
use AI::CBR::Retrieval;
my $case = AI::CBR::Case->new(...);
my $r = AI::CBR::Retrieval->new($case, \@case_base);
...
=head1 DESCRIPTION
Framework for Case-Based Reasoning in Perl.
For an overview, please see my slides from YAPC::EU 2009.
In brief, you need to specifiy an L<AI::CBR::Case>
with the help of similarity functions from L<AI::CBR::Sim>.
Then you can find similar cases from a case-base
with L<AI::CBR::Retrieval>.
The technical documentation can be found in the
individual modules of this distribution.
=head1 SEE ALSO
=over 4
=item * L<AI::CBR::Sim>
=item * L<AI::CBR::Case>
=item * L<AI::CBR::Case::Compound>
=item * L<AI::CBR::Retrieval>
=back
=head1 AUTHOR
Darko Obradovic, C<< <dobradovic at gmx.de> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-ai-cbr at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=AI-CBR>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::CBR
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=AI-CBR>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/AI-CBR>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/AI-CBR>
=item * Search CPAN
L<http://search.cpan.org/dist/AI-CBR>
=back
=head1 COPYRIGHT & LICENSE
Copyright 2009 Darko Obradovic, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of AI::CBR::Case
lib/AI/CBR/Case.pm view on Meta::CPAN
package AI::CBR::Case;
use warnings;
use strict;
our $DEFAULT_WEIGHT = 1;
=head1 NAME
AI::CBR::Case - case definition and representation
=head1 SYNOPSIS
Define and initialise a case.
In a productive system, you will want to encapsulate this.
use AI::CBR::Case;
use AI::CBR::Sim qw(sim_frac sim_eq sim_set);
# assume we are a doctor and see a patient
# shortcut one-time generated case
my $case = AI::CBR::Case->new(
age => { value => 30, sim => \&sim_frac },
gender => { value => 'male', sim => \&sim_eq },
job => { value => 'programmer', sim => \&sim_eq },
symptoms => { value => [qw(headache)], sim => \&sim_set },
);
# or case-specification with changing data
my $patient_case = AI::CBR::Case->new(
age => { sim => \&sim_frac },
gender => { sim => \&sim_eq },
job => { sim => \&sim_eq },
symptoms => { sim => \&sim_set },
);
foreach my $patient (@waiting_queue) {
$patient_case->set_values( %$patient ); # assume $patient is a hashref with the right attributes
...
}
...
=head1 METHODS
=head2 new
Creates a new case specification.
Pass a hash of hash references as argument.
The hash keys identify the attributes of the case,
the hash reference specifies this attribute,
with the following values:
=over 4
=item * B<sim>: a reference to the similarity function to use for this attribute
=item * B<param>: the parameter for the similarity function, if required
=item * B<weight>: the weight of the attribute in the comparison of the case. If you do not give a weight value for an attribute, the package's C<$DEFAULT_WEIGHT> will be used, which is 1 by default.
=item * B<value>: the value of the attribute, if you want to specify the complete case immediately. You can also do this later.
=back
=cut
sub new {
my ($class, %attributes) = @_;
# set default weights if unspecified
foreach (keys %attributes) {
$attributes{$_}->{weight} = $DEFAULT_WEIGHT unless defined $attributes{$_}->{weight};
}
my $self = \%attributes;
bless $self, $class;
return $self;
}
=head2 set_values
Pass a hash of attribute keys and values.
This will overwrite existing values, and can thus be used as a faster method
for generating new cases with the same specification.
=cut
sub set_values {
my ($self, %values) = @_;
foreach (keys %values) {
$self->{$_}->{value} = $values{$_};
}
}
=head1 SEE ALSO
See L<AI::CBR> for an overview of the framework.
=head1 AUTHOR
Darko Obradovic, C<< <dobradovic at gmx.de> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-ai-cbr at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=AI-CBR>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::CBR::Case
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=AI-CBR>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/AI-CBR>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/AI-CBR>
=item * Search CPAN
L<http://search.cpan.org/dist/AI-CBR>
=back
=head1 COPYRIGHT & LICENSE
Copyright 2009 Darko Obradovic, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of AI::CBR::Case
lib/AI/CBR/Case/Compound.pm view on Meta::CPAN
package AI::CBR::Case::Compound;
use warnings;
use strict;
our $DEFAULT_WEIGHT = 1;
=head1 NAME
AI::CBR::Case::Compound - compound case definition and representation
=head1 SYNOPSIS
Define and initialise a compound (or object-oriented) case.
This is a case consisting of multiple object definitions related in some way.
In a productive system, you will want to encapsulate this.
use AI::CBR::Case::Compound;
use AI::CBR::Sim qw(sim_eq sim_dist);
# assume we sell travels with flight and hotel
# shortcut one-time generated case
my $case = AI::CBR::Case::Compound->new(
# flight object
{
flight_start => { value => 'FRA', sim => \&sim_eq },
flight_target => { value => 'LIS', sim => \&sim_eq },
price => { value => 300, sim => \&sim_dist, param => 200 },
},
# hotel object
{
stars => { value => 3, sim => \&sim_dist, param => 2 },
rate => { value => 60, sim => \&sim_dist, param => 200 },
},
);
...
=head1 METHODS
=head2 new
Creates a new compound case specification.
Pass a list of hash references as argument.
Each hash reference is the same specification as passed to L<AI::CBR::Case>.
=cut
sub new {
my ($class, @definitions) = @_;
# set default weights if unspecified
foreach my $attributes (@definitions) {
foreach (keys %$attributes) {
$attributes->{$_}->{weight} = $DEFAULT_WEIGHT unless defined $attributes->{$_}->{weight};
}
}
my $self = \@definitions;
bless $self, $class;
return $self;
}
=head2 set_values
Pass a flat hash of attribute keys and values.
This will overwrite existing values, and can thus be used as a faster method
for generating new cases with the same specification.
Notice that keys in the different specifications of the compound object may not have the same name!
=cut
sub set_values {
my ($self, %values) = @_;
foreach my $spec (@$self) {
foreach (keys %$spec) {
$spec->{$_}->{value} = $values{$_};
}
}
}
=head1 SEE ALSO
See L<AI::CBR> for an overview of the framework.
=head1 AUTHOR
Darko Obradovic, C<< <dobradovic at gmx.de> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-ai-cbr at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=AI-CBR>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::CBR::Case::Compound
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=AI-CBR>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/AI-CBR>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/AI-CBR>
=item * Search CPAN
L<http://search.cpan.org/dist/AI-CBR>
=back
=head1 COPYRIGHT & LICENSE
Copyright 2009 Darko Obradovic, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of AI::CBR::Case::Compound
lib/AI/CBR/Retrieval.pm view on Meta::CPAN
package AI::CBR::Retrieval;
use warnings;
use strict;
use List::Util qw(min);
=head1 NAME
AI::CBR::Retrieval - retrieve similar cases from a case-base
=head1 SYNOPSIS
Retrieve solutions for a case from a case-base
use AI::CBR::Retrieval;
my $r = AI::CBR::Retrieval->new($case, \@case_base);
$r->compute_sims();
my $solution = $r->most_similar_case();
...
=head1 METHODS
=head2 new
Creates a new object for retrieval.
Pass your case specification object as the first parameter.
Pass the reference of an array of hash references as the case-base.
The hashes should contain all attributes of the specification.
These will be called candidate cases internally.
=cut
sub new {
my ($classname, $spec, $candidates) = @_;
croak('new case without candidates') unless @$candidates;
my $self = {
candidates => $candidates,
# we accept single specs as hash-ref or composed specs as array-ref
# internally both will be handled as a composed array-ref
queries => ref $spec eq 'AI::CBR::Case' ? [$spec] : $spec,
};
bless $self, $classname;
return $self;
}
=head2 compute_sims
If the case-specification is complete,
you may call this method to compute the similarities
of all candidate cases to this specification.
After this step, each candidate of the case-base will have an
additional attribute C<_sim> indicating the similarity.
=cut
sub compute_sims {
my ($self) = @_;
# pre-allocate variables used in loop
my ($sum_sims, $sum_weights, $att_key, $att, $weight, $x, $y);
my $num_queries = int @{$self->{queries}};
foreach my $candidate (@{$self->{candidates}}) {
$candidate->{_sim} = 1;
foreach my $query (@{$self->{queries}}) {
$sum_sims = 0;
$sum_weights = 0;
ATTRIBUTES:
while(($att_key, $att) = each(%{$query})) {
next ATTRIBUTES unless $weight = $att->{weight};
$sum_weights += $weight;
$x = $att->{value};
$y = $candidate->{$att_key};
$sum_sims += $weight * (
!defined $x && !defined $y ? 1
: !defined $x || !defined $y ? 0
: &{$att->{sim}}($x, $y, $att->{param} || 0)
);
}
$candidate->{_sim} *= _nrt($num_queries, $sum_sims / $sum_weights);
}
}
my @candidates_sorted = sort { $b->{_sim} <=> $a->{_sim} } @{$self->{candidates}};
$self->{candidates} = \@candidates_sorted;
}
=head2 RETRIEVAL METHODS
Use one of these methods to get the similar cases you are interested into.
=head3 most_similar_candidate
Returns the most similar candidate.
No parameters.
=cut
sub most_similar_candidate {
my ($self) = @_;
return $self->{candidates}->[0];
}
=head3 n_most_similar_candidates
Returns the n most similar candidates.
n is the only parameter.
=cut
sub n_most_similar_candidates {
my ($self, $n) = @_;
my $last_index = min($n - 1, int @{$self->{candidates}});
return map { $self->{candidates}->[$_] } (0 .. $last_index);
}
=head3 first_confirmed_candidate
Returns the first candidate that is confirmed by a later candidate.
Confirmation is based on an attribute value
whose key is passed as parameter.
In case there is no confirmed candidate at all,
simply returns the most similar one.
=cut
sub first_confirmed_candidate {
my ($self, $key) = @_;
my %candidate_with;
my $value;
foreach my $candidate (@{$self->{candidates}}) {
$value = $candidate->{$key};
if($candidate_with{$value}) {
return $candidate_with{$value};
} else {
$candidate_with{$value} = $candidate;
}
}
# no confirmed candidate found, fall back
return $self->most_similar_candidate();
}
# internal method for n-th root
sub _nrt {
return $_[1] ** (1 / $_[0]);
}
=head1 SEE ALSO
See L<AI::CBR> for an overview of the framework.
=head1 AUTHOR
Darko Obradovic, C<< <dobradovic at gmx.de> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-ai-cbr at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=AI-CBR>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::CBR::Retrieval
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=AI-CBR>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/AI-CBR>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/AI-CBR>
=item * Search CPAN
L<http://search.cpan.org/dist/AI-CBR>
=back
=head1 COPYRIGHT & LICENSE
Copyright 2009 Darko Obradovic, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of AI::CBR::Retrieval
lib/AI/CBR/Sim.pm view on Meta::CPAN
package AI::CBR::Sim;
use warnings;
use strict;
use Exporter;
our @ISA = ('Exporter');
our @EXPORT_OK = qw(sim_dist sim_frac sim_eq sim_set);
=head1 NAME
AI::CBR::Sim - collection of basic similarity functions
=head1 SYNOPSIS
Import similarity functions for case construction.
use AI::CBR::Sim qw(sim_dist sim_eq);
...
...
=head1 EXPORT
=over 4
=item * sim_dist
=item * sim_frac
=item * sim_eq
=item * sim_set
=back
=head1 FUNCTIONS
=head2 sim_dist
Works for any numeric values.
Suitable when you are interested into the difference of values in a given range.
Returns the fraction of the difference of the values with respect to a given maximum range of interest.
The madatory third argument is this range.
sim_dist(26, 22, 10); # returns 0.4
sim_dist(-2, 1, 100); # returns 0.03
=cut
sub sim_dist {
my ($a, $b, $range) = @_;
return 1 if $a == $b;
my $dist = abs($a - $b);
return 0 if $dist >= $range;
return 1 - $dist / $range;
}
=head2 sim_frac
Works for non-negative numeric values.
Suitable when you are only interested into their relative difference with respect to 0.
Returns the fraction of the smaller argument with respect to the higher one.
sim_frac(3, 2); # returns 0.67
sim_frac(40, 50); # returns 0.8
=cut
sub sim_frac {
my ($a, $b) = @_;
return 1 if $a == $b;
return 0 if $a * $b == 0;
return $a > $b ? $b / $a : $a / $b;
}
=head2 sim_eq
Works for any textual value.
Suitable when you are interested only into equality/inequality.
Returns 1 in case of equality, 0 in case of inequality.
No third argument.
sim_eq('foo', 'bar'); # returns 0
sim_eq('foo', 'foo'); # returns 1
=cut
sub sim_eq {
return $_[0] eq $_[1] ? 1 : 0;
}
=head2 sim_set
Works for sets/lists of textual values.
Suitable when you are interested into overlap of the two sets.
Arguments are two array references with textual values.
Returns the number of elements in the intersection
divided by the number of elements in the union.
No third argument.
sim_set([qw/a b c/], [qw/b c d/]); # returns 0.5
sim_set([qw/a b c/], [qw/c/]); # returns 0.33
=cut
sub sim_set {
my ($a, $b) = @_;
return 1 if int @$a == 0 && int @$b == 0;
return 0 unless int @$a && int @$b;
my %a = map { ($_ => 1) } @$a;
my $union = int keys %a;
my $intersection = 0;
map {
$a{$_} ? $intersection++ : $union++
} @$b;
return $intersection / $union;
}
=head1 SEE ALSO
See L<AI::CBR> for an overview of the framework.
=head1 AUTHOR
Darko Obradovic, C<< <dobradovic at gmx.de> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-ai-cbr at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=AI-CBR>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::CBR::Sim
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=AI-CBR>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/AI-CBR>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/AI-CBR>
=item * Search CPAN
L<http://search.cpan.org/dist/AI-CBR>
=back
=head1 COPYRIGHT & LICENSE
Copyright 2009 Darko Obradovic, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of AI::CBR::Sim
t/00-load.t view on Meta::CPAN
#!perl -T
use Test::More tests => 4;
BEGIN {
use_ok( 'AI::CBR::Sim' );
use_ok( 'AI::CBR::Case' );
use_ok( 'AI::CBR::Retrieval' );
use_ok( 'AI::CBR::Case::Compound' );
}
diag( "Testing AI::CBR::Case $AI::CBR::Case::VERSION, Perl $], $^X" );
#!perl -T
use Test::More tests => 22;
use AI::CBR::Sim qw(sim_dist sim_frac sim_eq sim_set);
# sim_dist
is(sim_dist(26,22,10), 0.6, 'sim_dist works');
is(sim_dist(-1,-0.9,0.5), 0.8, 'sim_dist works');
is(sim_dist(0,4,8), 0.5, 'sim_dist works');
# sim_frac
is(sim_frac(0,0), 1, 'sim_frac works');
is(sim_frac(0,2), 0, 'sim_frac works');
is(sim_frac(4,0), 0, 'sim_frac works');
is(sim_frac(2,4), 0.5, 'sim_frac works');
is(sim_frac(16,4), 0.25, 'sim_frac works');
is(sim_frac(100,40), 0.4, 'sim_frac works');
# sim_eq
is(sim_eq('a','b'), 0, 'sim_eq works');
is(sim_eq('','b'), 0, 'sim_eq works');
is(sim_eq('a',''), 0, 'sim_eq works');
is(sim_eq('a','a'), 1, 'sim_eq works');
# sim_set
is(sim_set([], []), 1, 'sim_set works');
is(sim_set([qw(a b c)], []), 0, 'sim_set works');
is(sim_set([], [qw(d e f)]), 0, 'sim_set works');
is(sim_set([qw(a b)], [qw(c d)]), 0, 'sim_set works');
is(sim_set([qw(a b)], [qw(b c)]), 1/3, 'sim_set works');
is(sim_set([qw(a b c)], [qw(b c d)]), 0.5, 'sim_set works');
is(sim_set([qw(a b c d)], [qw(d e f g)]), 1/7, 'sim_set works');
is(sim_set([qw(a b c d)], [qw(a b c)]), 0.75, 'sim_set works');
is(sim_set([qw(a b c d)], [qw(a b c d)]), 1, 'sim_set works');
t/02-case.t view on Meta::CPAN
#!perl -T
use Test::More tests => 2;
use AI::CBR::Sim qw(sim_dist sim_frac sim_eq sim_set);
use AI::CBR::Case;
my $case1 = AI::CBR::Case->new(
age => { value => 30, sim => \&sim_amount },
gender => { value => 'male', sim => \&sim_eq },
job => { value => 'programmer', sim => \&sim_eq },
symptoms => { value => [qw(headache)], sim => \&sim_set, weight =>2 },
);
my $weights_at_1 = int grep { $case1->{$_}->{weight} == 1 } keys %$case1;
my $weights_at_2 = int grep { $case1->{$_}->{weight} == 2 } keys %$case1;
is($weights_at_1, 3, 'default weights set to 1');
is($weights_at_2, 1, 'symptom weight set to 2');
t/03-retrieval.t view on Meta::CPAN
#!perl -T
use Test::More tests => 7;
use AI::CBR::Sim qw(sim_frac sim_eq sim_set);
use AI::CBR::Case;
use AI::CBR::Retrieval;
my $case_base = [
{id=>1, age=>25, gender=>'male', job=>'manager', symptoms=>[qw(headache)], reason=>'stress' },
{id=>2, age=>40, gender=>'male', job=>'programmer', symptoms=>[qw(headache cough)], reason=>'flu' },
{id=>3, age=>30, gender=>'female', job=>'programmer', symptoms=>[qw(cough)], reason=>'flu' },
{id=>4, age=>25, gender=>'male', job=>'programmer', symptoms=>[qw(headache)], reason=>'alcohol'},
];
my $case1 = AI::CBR::Case->new(
age => { value => 30, sim => \&sim_frac },
gender => { value => 'male', sim => \&sim_eq },
job => { value => 'programmer', sim => \&sim_eq },
symptoms => { value => [qw(headache)], sim => \&sim_set, weight =>2 },
);
my $retrieval = AI::CBR::Retrieval->new($case1, $case_base);
$retrieval->compute_sims();
# check similarities
is($case_base->[0]->{_sim}, (5/6+1+0+2*1/1)/5, 'sim 1 correct'); # ~0.77
is($case_base->[1]->{_sim}, (3/4+1+1+2*1/2)/5, 'sim 2 correct'); # 0.75
is($case_base->[2]->{_sim}, (1/1+0+1+2*0/2)/5, 'sim 3 correct'); # 0.4
is($case_base->[3]->{_sim}, (5/6+1+1+2*1/1)/5, 'sim 4 correct'); # ~0.97
# check retrieval
is($retrieval->most_similar_candidate->{id}, 4, 'most similar candidate returned');
is($retrieval->n_most_similar_candidates(3), 3, 'n most similar candidates returned');
is($retrieval->first_confirmed_candidate('reason')->{id}, 2, 'first confirmed reason candidate returned');
t/04-case-compound.t view on Meta::CPAN
#!perl -T
use Test::More tests => 5;
use AI::CBR::Sim qw(sim_dist sim_frac sim_eq sim_set);
use AI::CBR::Case::Compound;
use AI::CBR::Retrieval;
my $case1 = AI::CBR::Case::Compound->new(
# flight object
{
start => { value => 'FRA', sim => \&sim_eq },
target => { value => 'LIS', sim => \&sim_eq },
price => { value => 300, sim => \&sim_dist, param => 200 },
},
# hotel object
{
stars => { value => 3, sim => \&sim_dist, param => 2 },
rate => { value => 60, sim => \&sim_dist, param => 200 },
},
);
is(int @$case1, 2, '2 specs');
my @case_base = (
{id=>1, start=>'FRA', target=>'DBV', price=>200, stars=>5, rate=>160}, # ~0.35
{id=>2, start=>'FRA', target=>'LIS', price=>350, stars=>4, rate=>80}, # ~0.80
);
my $r = AI::CBR::Retrieval->new($case1, \@case_base);
$r->compute_sims();
is($r->{candidates}->[0]->{id}, 2, 'sim of id 2 is higher');
is($r->{candidates}->[1]->{id}, 1, 'sim of id 1 is lower');
is($case_base[0]->{_sim}, sqrt(0.5*0.25), 'sim of id 1 correct');
is($case_base[1]->{_sim}, sqrt((2.75/3)*(1.4/2)), 'sim of id 2 correct');
t/boilerplate.t view on Meta::CPAN
#!perl -T
use strict;
use warnings;
use Test::More tests => 4;
sub not_in_file_ok {
my ($filename, %regex) = @_;
open( my $fh, '<', $filename )
or die "couldn't open $filename for reading: $!";
my %violated;
while (my $line = <$fh>) {
while (my ($desc, $regex) = each %regex) {
if ($line =~ $regex) {
push @{$violated{$desc}||=[]}, $.;
}
}
}
if (%violated) {
fail("$filename contains boilerplate text");
diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
} else {
pass("$filename contains no boilerplate text");
}
}
sub module_boilerplate_ok {
my ($module) = @_;
not_in_file_ok($module =>
'the great new $MODULENAME' => qr/ - The great new /,
'boilerplate description' => qr/Quick summary of what the module/,
'stub function definition' => qr/function[12]/,
);
}
TODO: {
local $TODO = "Need to replace the boilerplate text";
not_in_file_ok(README =>
"The README is used..." => qr/The README is used/,
"'version information here'" => qr/to provide version information/,
);
not_in_file_ok(Changes =>
"placeholder date/time" => qr(Date/time)
);
module_boilerplate_ok('lib/AI/CBR/Case.pm');
module_boilerplate_ok('lib/AI/CBR/Sim.pm');
}
t/pod-coverage.t view on Meta::CPAN
use strict;
use warnings;
use Test::More;
# Ensure a recent version of Test::Pod::Coverage
my $min_tpc = 1.08;
eval "use Test::Pod::Coverage $min_tpc";
plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
if $@;
# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
# but older versions don't recognize some common documentation styles
my $min_pc = 0.18;
eval "use Pod::Coverage $min_pc";
plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
if $@;
all_pod_coverage_ok();
#!perl -T
use strict;
use warnings;
use Test::More;
# Ensure a recent version of Test::Pod
my $min_tp = 1.22;
eval "use Test::Pod $min_tp";
plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
all_pod_files_ok();
( run in 0.437 second using v1.01-cache-2.11-cpan-4d50c553e7e )