Algorithm-Classifier-NaiveBayes
view release on metacpan or search on metacpan
$nb->train( 'spam', 'buy cheap pills now' );
$nb->train( 'spam', 'cheap watches for sale' );
$nb->train( 'ham', 'meeting at noon tomorrow' );
$nb->train( 'ham', 'lunch with the team' );
# classify some new text
my $class = $nb->classify('cheap pills for sale');
# $class is now 'spam'
# or get the score for every class as well
my ( $best, $scores ) = $nb->classify('cheap pills for sale');
# save the model for later and load it again
$nb->save('model.json');
my $loaded = Algorithm::Classifier::NaiveBayes->new;
$loaded->load('model.json');
```
For full documentation see the POD for the module. Runnable examples,
including small command line training and classification scripts, can
examples/classify.pl view on Meta::CPAN
#!perl
# Classifies text using a model saved by train.pl, printing the best
# match and then the score for every class.
#
# perl classify.pl model.json 'cheap pills for sale'
#
# Or read the text to classify from stdin...
#
# cat some_message.txt | perl classify.pl model.json
use strict;
use warnings;
use Algorithm::Classifier::NaiveBayes;
lib/Algorithm/Classifier/NaiveBayes.pm view on Meta::CPAN
$nb->train( 'spam', 'buy cheap pills now' );
$nb->train( 'spam', 'cheap watches for sale' );
$nb->train( 'ham', 'meeting at noon tomorrow' );
$nb->train( 'ham', 'lunch with the team' );
# classify some new text
my $class = $nb->classify('cheap pills for sale');
# $class is now 'spam'
# or get the score and probability for every class as well
my ( $best, $scores, $probs ) = $nb->classify('cheap pills for sale');
# save the model for later and load it again
$nb->save('model.json');
my $loaded = Algorithm::Classifier::NaiveBayes->new;
$loaded->load('model.json');
=head1 DESCRIPTION
This module implements a multinomial naive Bayes classifier. Strings
lib/Algorithm/Classifier/NaiveBayes.pm view on Meta::CPAN
if ( ( $total + ( $alpha * $token_size ) ) > 0 ) {
for my $token (@tokens) {
my $count = $self->{'model'}{'token_counts'}{$class}{$token} || 0;
$log_prob += log( ( $count + $alpha ) / ( $total + ( $alpha * $token_size ) ) );
}
}
$scores{$class} = $log_prob;
} ## end for my $class ( keys %{ $self->{'model'}{'class_counts'...}})
my ($best) = sort { $scores{$b} <=> $scores{$a} || $a cmp $b } keys %scores;
if ( !wantarray ) {
return $best;
}
# normalize the log scores into probabilities, shifting by the max
# so exp does not underflow for large negative log scores
my $max = $scores{$best};
my %probs;
my $prob_sum = 0;
for my $class ( keys %scores ) {
$probs{$class} = exp( $scores{$class} - $max );
$prob_sum += $probs{$class};
}
for my $class ( keys %probs ) {
$probs{$class} = $probs{$class} / $prob_sum;
}
return ( $best, \%scores, \%probs );
} ## end sub classify
=head2 explain
Classifies the text in question like classify, but returns a hash ref
breaking down how the result was arrived at.
my $explanation = $nb->explain($text);
The returned hash ref is as below.
class - The best matching class, as classify would return.
scores - Hash ref of the log score of every class, as classify
would return.
probs - Hash ref of the probability of every class, as classify
would return.
priors - Hash ref of the log prior probability of every class,
the part of the score that comes from how often the class was
trained rather than from the tokens.
lib/Algorithm/Classifier/NaiveBayes.pm view on Meta::CPAN
my $count = $self->{'model'}{'token_counts'}{$class}{$token} || 0;
my $contribution = log( ( $count + $alpha ) / $denom );
$token_info{$token}{'count'} = $text_counts{$token};
$token_info{$token}{'contributions'}{$class} = $contribution;
$log_prob += $contribution * $text_counts{$token};
}
}
$scores{$class} = $log_prob;
} ## end for my $class ( keys %{ $self->{'model'}{'class_counts'...}})
my ($best) = sort { $scores{$b} <=> $scores{$a} || $a cmp $b } keys %scores;
my $max = $scores{$best};
my %probs;
my $prob_sum = 0;
for my $class ( keys %scores ) {
$probs{$class} = exp( $scores{$class} - $max );
$prob_sum += $probs{$class};
}
for my $class ( keys %probs ) {
$probs{$class} = $probs{$class} / $prob_sum;
}
return {
'class' => $best,
'scores' => \%scores,
'probs' => \%probs,
'priors' => \%priors,
'tokens' => \%token_info,
};
} ## end sub explain
=head2 tweak
Changes scoring settings on a existing model. Takes the args below,
lib/Algorithm/Classifier/NaiveBayes/App/Command/classify.pm view on Meta::CPAN
[ 'json', 'Print the class, scores, and probs as JSON instead.' ],
);
}
sub abstract { 'Classify the specified text' }
sub description {
return 'Classify the specified text using a saved model.
The text is taken from the remaining args joined by a space, or from
stdin if no args are given. The best matching class is printed.
nb_tool classify -m model.json cheap pills for sale
cat some_message.txt | nb_tool classify -m model.json -p
';
} ## end sub description
sub validate {
my ( $self, $opt, $args ) = @_;
if ( !-f $opt->{'m'} ) {
t/04-classify.t view on Meta::CPAN
use Algorithm::Classifier::NaiveBayes;
my $nb = Algorithm::Classifier::NaiveBayes->new;
$nb->train( 'spam', 'buy cheap pills now cheap' );
$nb->train( 'ham', 'meeting at noon tomorrow' );
$nb->train( 'ham', 'lunch meeting tomorrow' );
is( $nb->classify('buy cheap pills'), 'spam', 'classifies spam' );
is( $nb->classify('meeting noon tomorrow'), 'ham', 'classifies ham' );
my ( $best, $scores, $probs ) = $nb->classify('cheap pills');
is( $best, 'spam', 'list context returns best class' );
is( ref($scores), 'HASH', 'list context returns scores hashref' );
is_deeply( [ sort keys %{$scores} ], [ 'ham', 'spam' ], 'scores has an entry per class' );
ok( $scores->{'spam'} > $scores->{'ham'}, 'winning class has the highest score' );
ok( $scores->{'spam'} < 0, 'scores are log probabilities' );
# probabilities
is( ref($probs), 'HASH', 'list context returns probs hashref' );
is_deeply( [ sort keys %{$probs} ], [ 'ham', 'spam' ], 'probs has an entry per class' );
ok( $probs->{'spam'} > $probs->{'ham'}, 'winning class has the highest probability' );
ok( abs( $probs->{'spam'} + $probs->{'ham'} - 1 ) < 1e-9, 'probabilities sum to 1' );
ok( $probs->{'spam'} > 0 && $probs->{'spam'} <= 1, 'probabilities are between 0 and 1' );
ok( $probs->{'ham'} > 0, 'losing class probability is greater than 0' );
# unseen tokens are smoothed rather than dying
my $unseen = $nb->classify('zebra quantum');
ok( defined($unseen), 'classify handles entirely unseen tokens' );
# untrained model
my $empty = Algorithm::Classifier::NaiveBayes->new;
is( $empty->classify('anything'), undef, 'untrained classify returns undef' );
my ( $ebest, $escores, $eprobs ) = $empty->classify('anything');
is( $ebest, undef, 'untrained classify returns undef in list context' );
is_deeply( $escores, {}, 'untrained classify returns empty scores' );
is_deeply( $eprobs, {}, 'untrained classify returns empty probs' );
# tie breaking is deterministic
my $tie = Algorithm::Classifier::NaiveBayes->new;
$tie->train( 'b', 'foo' );
$tie->train( 'a', 'foo' );
is( $tie->classify('foo'), 'a', 'ties break deterministically by class name' );
# tied classes have equal probabilities
my ( $tbest, $tscores, $tprobs ) = $tie->classify('foo');
ok( abs( $tprobs->{'a'} - 0.5 ) < 1e-9, 'tied classes split the probability evenly' );
# lidstone smoothing
# one class, two trained tokens, so a unseen token scores
# log( (0 + alpha) / (2 + alpha * 2) )
my $lid = Algorithm::Classifier::NaiveBayes->new( 'smoothing' => 'lidstone', 'alpha' => 0.5 );
$lid->train( 'only', 'aa bb' );
my ( $lbest, $lscores ) = $lid->classify('cc');
ok( abs( $lscores->{'only'} - log( 0.5 / 3 ) ) < 1e-9, 'lidstone alpha is used in smoothing' );
my $lap = Algorithm::Classifier::NaiveBayes->new;
$lap->train( 'only', 'aa bb' );
my ( $lapbest, $lapscores ) = $lap->classify('cc');
ok( abs( $lapscores->{'only'} - log( 1 / 4 ) ) < 1e-9, 'laplace smoothing unchanged' );
# binary token weighting dedupes the text being classified
# one class trained "aa bb", so classifying "aa aa" binary scores
# log( (1 + 1) / (2 + 2) ) for the single deduped aa
my $bin = Algorithm::Classifier::NaiveBayes->new( 'token_weighting' => 'binary' );
$bin->train( 'only', 'aa bb' );
my ( $binbest, $binscores ) = $bin->classify('aa aa');
ok( abs( $binscores->{'only'} - log( 2 / 4 ) ) < 1e-9, 'binary weighting dedupes tokens when classifying' );
# uniform priors
# with no tokens the score is just the prior, so a unbalanced training
# set shows the difference between trained and uniform priors
my $trained_priors = Algorithm::Classifier::NaiveBayes->new;
$trained_priors->train( 'a', 'xx' );
$trained_priors->train( 'a', 'yy' );
$trained_priors->train( 'b', 'xx' );
my ( $tpbest, $tpscores ) = $trained_priors->classify('');
ok( abs( $tpscores->{'a'} - log( 2 / 3 ) ) < 1e-9, 'trained priors reflect training balance' );
my $uniform_priors = Algorithm::Classifier::NaiveBayes->new( 'priors' => 'uniform' );
$uniform_priors->train( 'a', 'xx' );
$uniform_priors->train( 'a', 'yy' );
$uniform_priors->train( 'b', 'xx' );
my ( $upbest, $upscores ) = $uniform_priors->classify('');
ok( abs( $upscores->{'a'} - log( 1 / 2 ) ) < 1e-9, 'uniform priors are log(1/classes)' );
ok( abs( $upscores->{'a'} - $upscores->{'b'} ) < 1e-9, 'uniform priors are equal for every class' );
done_testing;
t/12-tweak.t view on Meta::CPAN
$nb->tweak( 'smoothing' => 'lidstone', 'alpha' => 0.5 );
is( $nb->{'model'}{'smoothing'}, 'lidstone', 'tweak changes smoothing' );
is( $nb->{'model'}{'alpha'}, 0.5, 'tweak changes alpha' );
# the new alpha is actually used when scoring... one class, two trained
# tokens, so a unseen token scores log( (0 + 0.5) / (2 + 0.5 * 2) )
my $scored = Algorithm::Classifier::NaiveBayes->new;
$scored->train( 'only', 'aa bb' );
$scored->tweak( 'smoothing' => 'lidstone', 'alpha' => 0.5 );
my ( $sbest, $sscores ) = $scored->classify('cc');
ok( abs( $sscores->{'only'} - log( 0.5 / 3 ) ) < 1e-9, 'tweaked alpha is used when classifying' );
# switching to lidstone without a alpha keeps the current alpha
my $keep = Algorithm::Classifier::NaiveBayes->new;
$keep->tweak( 'smoothing' => 'lidstone' );
is( $keep->{'model'}{'alpha'}, 1, 'switching to lidstone without alpha keeps the current alpha' );
# switching back to laplace forces alpha back to 1
$nb->tweak( 'smoothing' => 'laplace' );
is( $nb->{'model'}{'smoothing'}, 'laplace', 'tweak can switch back to laplace' );
is( $nb->{'model'}{'alpha'}, 1, 'switching to laplace forces alpha to 1' );
##
## priors
##
$nb->tweak( 'priors' => 'uniform' );
is( $nb->{'model'}{'priors'}, 'uniform', 'tweak changes priors' );
my ( $ubest, $uscores ) = $nb->classify('');
ok( abs( $uscores->{'spam'} - $uscores->{'ham'} ) < 1e-9, 'tweaked priors are used when classifying' );
##
## only defined args are changed
##
my $solo = Algorithm::Classifier::NaiveBayes->new( 'smoothing' => 'lidstone', 'alpha' => 0.3 );
$solo->tweak( 'priors' => 'uniform' );
is( $solo->{'model'}{'smoothing'}, 'lidstone', 'tweaking priors does not touch smoothing' );
is( $solo->{'model'}{'alpha'}, 0.3, 'tweaking priors does not touch alpha' );
( run in 0.600 second using v1.01-cache-2.11-cpan-9581c071862 )