view release on metacpan or  search on metacpan

lib/Algorithm/Classifier/NaiveBayes.pm  view on Meta::CPAN

package Algorithm::Classifier::NaiveBayes;

use 5.006;
use strict;
use warnings;
use JSON::PP    ();
use File::Slurp qw(read_file write_file);

=head1 NAME

Algorithm::Classifier::NaiveBayes - A multinomial naive Bayes text classifier with Laplace smoothing.

=head1 VERSION

Version 0.0.1

=cut

our $VERSION = '0.0.1';

# version of the saved model format
our $MODEL_VERSION = 1;

=head1 SYNOPSIS

    use Algorithm::Classifier::NaiveBayes;

    my $nb = Algorithm::Classifier::NaiveBayes->new;

    # train it with examples of each class
    $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
are broken into tokens and each class is scored using the log of its
prior probability, based on how often the class was trained, plus the
sum of the log probabilities of each token appearing in that class.
Token probabilities are smoothed so tokens never seen for a class do
not zero out the whole score. By default this is add-one, Laplace,
smoothing, but Lidstone, add-alpha, smoothing with a configurable
alpha may be selected instead. Smaller alphas, such as 0.1 to 0.5,
often perform better on small training sets.

By default token occurrences are weighted by their raw counts, but
binary weighting, counting each unique token once per document, may
be selected instead via token_weighting. Class priors default to how
often each class was trained, but may be set to uniform via priors.

Classes are not predefined. A class exists once something has been
trained for it and stops existing if everything for it is untrained.

The model may be saved to a JSON file or string and loaded back later,
allowing training and classification to happen in different processes.

=head1 METHODS

=head2 new

Initiates the object.

    my $nb = Algorithm::Classifier::NaiveBayes->new(%args);

The following args are supported.

    lc_tokens - Lowercase tokens when tokenizing.
        Default: 1

    token_splitter - Regex to use for splitting a string into tokens.
        Default: \s+

    stop_regex - If defined, tokens matching this regex are dropped.
        Matched anchored, so it must match the entire token.
        Default: undef

    smoothing - The smoothing to use for token probabilities. Either
        "laplace", add-one, or "lidstone", add-alpha.
        Default: laplace

    alpha - The alpha to use for lidstone smoothing. Must be a number
        greater than 0. May only be specified when smoothing is set to
        lidstone. Laplace smoothing is lidstone with a alpha of 1.
        Default: 0.5

    ngrams - Max size of n-grams to generate from adjacent tokens when

lib/Algorithm/Classifier/NaiveBayes.pm  view on Meta::CPAN

In scalar context, returns the name of the class the text most likely
belongs to. In list context, also returns a hash ref of the score for
every class as well as a hash ref of the probability of every class.

    my ( $class, $scores, $probs ) = $nb->classify($text);
    foreach my $possible ( sort { $scores->{$b} <=> $scores->{$a} } keys %{$scores} ) {
        print $possible . ': ' . $scores->{$possible} . ', ' . $probs->{$possible} . "\n";
    }

The scores are log probabilities, so they are negative numbers with
the one closest to zero being the most likely.

The probabilities are the scores normalized to sum to 1, so they may
be used for things like requiring a minimum confidence.

    my ( $class, $scores, $probs ) = $nb->classify($text);
    if ( $probs->{$class} < 0.8 ) {
        $class = 'unsure';
    }

It is worth noting naive Bayes probabilities tend to be overconfident
thanks to the assumption tokens are independent of each other, with
longer texts commonly producing probabilities very close to 1 or 0.
They are good for ranking and thresholding, but should not be taken
as calibrated probabilities.

If nothing has been trained yet, undef is returned in scalar context
and ( undef, {}, {} ) in list context.

Ties are broken by sorting the tied class names, making the result
deterministic.

=cut

sub classify {
	my ( $self, $text ) = @_;

	if ( $self->{'model'}{'total_docs'} < 1 ) {
		return wantarray ? ( undef, {}, {} ) : undef;
	}

	my @tokens     = $self->_weighted_tokens( $self->tokenize($text) );
	my $token_size = scalar keys %{ $self->{'model'}{'tokens'} };
	my $alpha      = defined( $self->{'model'}{'alpha'} ) ? $self->{'model'}{'alpha'} : 1;

	my %scores;
	for my $class ( keys %{ $self->{'model'}{'class_counts'} } ) {
		my $log_prob = $self->_log_prior($class);
		my $total    = $self->{'model'}{'class_totals'}{$class} || 0;

		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.

    tokens - Hash ref of every token in the tokenized text. Each value
        is a hash ref with "count", how many times the token appeared
        in the text, and "contributions", a hash ref of the log
        probability that token added to each class per appearance.

For any class, the score is the prior plus count * contribution summed
over every token. A token pushes towards the class it has the highest,
closest to zero, contribution for. So finding the tokens most
responsible for a classification can be done like below.

    my $explanation = $nb->explain($text);
    my ( $first, $second ) =
        sort { $explanation->{'scores'}{$b} <=> $explanation->{'scores'}{$a} }
        keys %{ $explanation->{'scores'} };
    foreach my $token ( keys %{ $explanation->{'tokens'} } ) {
        my $contribs = $explanation->{'tokens'}{$token}{'contributions'};
        my $pull = ( $contribs->{$first} - $contribs->{$second} )
            * $explanation->{'tokens'}{$token}{'count'};
        print $token . ' pushed towards ' . $first . ' by ' . $pull . "\n";
    }

Will die if the text is undef. If nothing has been trained yet, undef
is returned.

=cut

sub explain {
	my ( $self, $text ) = @_;

	if ( !defined($text) ) {
		die('No text specified');
	}

	if ( $self->{'model'}{'total_docs'} < 1 ) {
		return undef;
	}

	my @tokens     = $self->_weighted_tokens( $self->tokenize($text) );
	my $token_size = scalar keys %{ $self->{'model'}{'tokens'} };
	my $alpha      = defined( $self->{'model'}{'alpha'} ) ? $self->{'model'}{'alpha'} : 1;

	my %text_counts;
	foreach my $token (@tokens) {
		$text_counts{$token}++;
	}

	my %priors;
	my %scores;
	my %token_info;
	for my $class ( keys %{ $self->{'model'}{'class_counts'} } ) {
		$priors{$class} = $self->_log_prior($class);
		my $log_prob = $priors{$class};
		my $total    = $self->{'model'}{'class_totals'}{$class} || 0;
		my $denom    = $total + ( $alpha * $token_size );

		if ( $denom > 0 ) {
			foreach my $token ( keys %text_counts ) {
				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,
all optional, but at least one must be specified.

    smoothing - The smoothing to use... laplace or lidstone.

    alpha - The alpha to use for lidstone smoothing. Must be a number
        greater than 0. May only be specified when the resulting
        smoothing is lidstone.

    priors - How class priors are computed... trained or uniform.

    # switch to lidstone smoothing with a alpha of 0.1
    $nb->tweak( 'smoothing' => 'lidstone', 'alpha' => 0.1 );

    # switch to uniform priors
    $nb->tweak( 'priors' => 'uniform' );

These are safe to change after training as they only affect scoring,
not the trained counts. Settings that shape the trained data, such as
ngrams, token_weighting, and the tokenizer settings, may not be
changed here as that would make the model inconsistent with what was
trained... for those, create a new object and retrain.

Only args specified with a defined value are changed. Args passed
with a undef value are ignored, so it is safe to pass through
possibly unset values.

Switching smoothing to laplace sets alpha to 1, as laplace is add-one.
Switching to lidstone without specifying alpha keeps the current
alpha.

Will die if passed a unknown arg, no args with defined values, or a
insane value. If it dies, the model is left unchanged.

=cut

sub tweak {
	my ( $self, %args ) = @_;

	my %known_args = ( 'smoothing' => 1, 'alpha' => 1, 'priors' => 1 );
	foreach my $arg ( keys %args ) {
		if ( !defined( $known_args{$arg} ) ) {
			die( '"' . $arg . '" is not a known arg' );
		}
	}
	if ( !grep { defined( $args{$_} ) } keys %args ) {
		die('No args specified');
	}

	# validate against what the settings would become
	my $smoothing = defined( $args{'smoothing'} ) ? $args{'smoothing'} : $self->{'model'}{'smoothing'};