AI-CBR
view release on metacpan or search on metacpan
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.
---
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' => {}
)
;
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
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
lib/AI/CBR.pm view on Meta::CPAN
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>
lib/AI/CBR/Case.pm view on Meta::CPAN
=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:
lib/AI/CBR/Case.pm view on Meta::CPAN
=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
lib/AI/CBR/Case.pm view on Meta::CPAN
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>
lib/AI/CBR/Case/Compound.pm view on Meta::CPAN
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
lib/AI/CBR/Case/Compound.pm view on Meta::CPAN
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>
lib/AI/CBR/Retrieval.pm view on Meta::CPAN
=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
lib/AI/CBR/Retrieval.pm view on Meta::CPAN
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>
lib/AI/CBR/Sim.pm view on Meta::CPAN
=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
lib/AI/CBR/Sim.pm view on Meta::CPAN
=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
lib/AI/CBR/Sim.pm view on Meta::CPAN
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>
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" );
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
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();
( run in 0.375 second using v1.01-cache-2.11-cpan-4d50c553e7e )