view release on metacpan or  search on metacpan

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

				$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 ) {

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

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'};
	if ( !defined($smoothing) ) {
		$smoothing = 'laplace';
	}
	if ( $smoothing ne 'laplace' && $smoothing ne 'lidstone' ) {
		die( 'smoothing must be either "laplace" or "lidstone" and not "' . $smoothing . '"' );
	}

	if ( defined( $args{'alpha'} ) ) {
		if ( $smoothing eq 'laplace' ) {
			die('alpha may only be specified when the resulting smoothing is lidstone');
		}
		if ( ref( $args{'alpha'} ) ne '' || $args{'alpha'} !~ /\A\d*\.?\d+\z/ || $args{'alpha'} <= 0 ) {
			die('alpha must be a number greater than 0');
		}
	}

	if ( defined( $args{'priors'} ) && $args{'priors'} ne 'trained' && $args{'priors'} ne 'uniform' ) {
		die( 'priors must be either "trained" or "uniform" and not "' . $args{'priors'} . '"' );
	}

	# only change what was specified with a defined value
	if ( defined( $args{'smoothing'} ) ) {
		$self->{'model'}{'smoothing'} = $args{'smoothing'};
		if ( $args{'smoothing'} eq 'laplace' ) {
			# laplace is add-one, so alpha is always 1
			$self->{'model'}{'alpha'} = 1;
		}
	}
	if ( defined( $args{'alpha'} ) ) {
		$self->{'model'}{'alpha'} = $args{'alpha'};
	}
	if ( defined( $args{'priors'} ) ) {
		$self->{'model'}{'priors'} = $args{'priors'};
	}
} ## end sub tweak

=head2 to_string

Returns the model as a JSON string. See the section MODEL FORMAT for
what the JSON looks like.

    my $json = $nb->to_string;

The JSON is generated with canonical set, so the keys are sorted,
meaning two calls against the same model will always produce identical
output, making it diffable.

If token_splitter or stop_regex was set to a qr// Regexp, it is
stringified, so the result is always JSON safe.

=cut

sub to_string {
	my ($self) = @_;

	# qr// Regexps can't be JSON encoded, so stringify them
	my %model = %{ $self->{'model'} };
	foreach my $regex_item ( 'token_splitter', 'stop_regex' ) {
		if ( ref( $model{$regex_item} ) eq 'Regexp' ) {
			$model{$regex_item} = '' . $model{$regex_item};
		}
	}

	return JSON::PP->new->encode( \%model );
} ## end sub to_string

=head2 from_string

Loads the model from the specified JSON string, replacing the current
model, including any settings passed to new for the object it is
being called on.

    $nb->from_string($json);

Will die on failure to parse the string as JSON, if "format" in the
JSON is not the name of this module, if "version" is newer than the
supported model format version, or if the parsed JSON does not look
like a saved model.

If it dies, the current model is left unchanged.

=cut

sub from_string {
	my ( $self, $raw ) = @_;

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

	my $model = eval { JSON::PP->new->decode($raw) };
	if ( !defined($model) ) {
		die( 'Failed to parse the string as JSON... ' . $@ );
	}

	if ( ref($model) ne 'HASH' ) {
		die('The string did not parse to a hash');
	}
	if ( !defined( $model->{'format'} ) || $model->{'format'} ne __PACKAGE__ ) {