view release on metacpan or  search on metacpan

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

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__ ) {
		die( '"format" is not "' . __PACKAGE__ . '"' );