Hola,
tras leer recientemente algunos capítulos del libro
Doing Bayesian Data Analysis, que trae todo el código escrito en
R, se me ocurrió explorar cómo construir en Perl un clasificador bayesiano ingenuo (
Naïve Bayes), del que recuerdo haber leído su aplicación hace tiempo en un trabajo de
Beer & Tavazoie para correlacionar secuencias reguladoras en cis y patrones de expresión de genes en levaduras.
Enseguida me crucé con un módulo de CPAN (
Algorithm::NaiveBayes) adecuado para entrenar un clasificador en basea observaciones codificadas en forma de vectores de atributos y la clase a la que pertenecen:
observación = (atributo1, atributo2, atributo3 : clase)
Sin embargo, mirando el código fuente no parece incluir la corrección de Laplace para frecuencias nulas. En esencia, esta corrección consiste en sumar a los datos empíricos, las observaciones, datos ficticios para segurarse que no sobreestimamos el modelo y para permitir clasificar muestras con atributos no vistos en el entrenamiento, sin alejarse de lo que indican los datos reales. Si todo esto te suena a chino te redirijo a este
vídeo y a este
blog. Esto se ha hecho muchas veces en Bioinformática, por ejemplo para construir matrices a partir de secuencias de DNA, como en el algoritmo
CONSENSUS de Hertz y Stormo.
Sigo buscando y me encuentro una versión muy compacta de clasificador Bayesiano basada en el módulo
Moose, que podéis ver en
http://asciirain.com/wordpress/2012/12/03/naive-bayes-in-42-lines . Tomo por tanto este código como punto de partida y lo modifico para permitir el uso de pseudoconteos de Laplace. Primero defino la clase myNaiveBayes:
package myNaiveBayes;
# modification of http://asciirain.com/wordpress/2012/12/03/naive-bayes-in-42-lines
# with Laplace smoothing (K param)
# allows missing features, which should be encoded as 'ND'
use Moose; # turns on strict and warnings
has class_counts => (is => 'ro', isa => 'HashRef[Int]', default => sub {{}});
has class_feature_counts => (is => 'ro', isa => 'ArrayRef[HashRef[HashRef[Num]]]', default => sub {[]});
has feature_counts => (is => 'ro', isa => 'ArrayRef[HashRef[Num]]', default => sub {[]});
has total_observations => (is => 'rw', isa => 'Num', default => 0);
has K => (is => 'ro', isa => 'Num', writer => '_set_K', default => 0);
sub insert
{
# insert observation, a vector of 'features', with last element being 'class'
# example: ('chrome','yahoo','us','good') , where class = 'good'
my( $self, @data ) = @_;
my $class = pop( @data );
$self->class_counts->{$class}++;
$self->total_observations( $self->total_observations + 1 );
for( my $i = 0; $i < @data; $i++ )
{
next if($data[$i] eq 'ND');
$self->feature_counts->[$i]->{$data[$i]}++;
$self->class_feature_counts->[$i]->{$class}->{$data[$i]}++;
}
return $self;
}
sub classify
{
# takes a feature vector (a new observation) of unknown class and returns a hash reference with
# probabilities of being associated to all previously seen classes
my( $self, @data ) = @_;
my ($i,$class,%probabilities,$feature_count,$class_feature_count);
my ($feature_probability,$conditional_probability,$class_count,$class_probability );
printf("# classify: training data = %d , K = %d \n",$self->total_observations,$self->K);
for $class ( keys %{ $self->class_counts } ){
$class_count = $self->class_counts->{$class};
$class_probability = $class_count / $self->total_observations;
($feature_probability, $conditional_probability) = (1.0,1.0);
for($i = 0; $i < @data; $i++){
$feature_count = $self->feature_counts->[$i]->{$data[$i]} + $self->K;
$class_feature_count = $self->class_feature_counts->[$i]->{$class}->{$data[$i]} + $self->K;
# if $self->K==0 (no pseudocounts) zero counts are omitted
next unless($feature_count && $class_feature_count);
$feature_probability *= $feature_count /
($self->total_observations + (keys(%{$self->feature_counts->[$i]}) * $self->K));
$conditional_probability *= $class_feature_count /
($class_count + (keys(%{$self->class_feature_counts->[$i]->{$class}}) * $self->K));
}
# p(class) * p(features|class)
# p(class|features) = ----------------------------
# p(features)
$probabilities{$class} = ($class_probability * $conditional_probability) / $feature_probability;
}
return \%probabilities;
}
no Moose;
__PACKAGE__->meta->make_immutable;
1;
Y ahora lo probamos con los mismos ejemplos del código en que me basé, creando un programa de nombre
nbayes.pl:
#!/usr/bin/env perl
use myNaiveBayes;
use constant PSEUDOCOUNTS => 1; # Laplace smoothing
my $K = $ARGV[0] || PSEUDOCOUNTS;
my $nb = myNaiveBayes->new( K => $K);
$nb->insert('chrome' ,'yahoo' ,'us', 'good');
$nb->insert('chrome' ,'slashdot','us', 'bad');
$nb->insert('chrome' ,'slashdot','uk', 'good');
$nb->insert('explorer','google' ,'us', 'good');
$nb->insert('explorer','slashdot','ca', 'good');
$nb->insert('firefox' ,'google' ,'ca', 'bad');
$nb->insert('firefox' ,'yahoo' ,'uk', 'good');
$nb->insert('firefox' ,'slashdot','us', 'good');
$nb->insert('firefox' ,'slashdot','us', 'bad');
$nb->insert('firefox' ,'slashdot','uk', 'bad');
$nb->insert('opera' ,'slashdot','ca', 'good');
$nb->insert('opera' ,'yahoo' ,'uk', 'bad');
$nb->insert('opera' ,'yahoo' ,'uk', 'bad');
my $ref_classes = $nb->classify('opera','slashdot', 'uk');
foreach my $class (sort { $ref_classes->{$a} <=> $ref_classes->{$b} } keys(%$ref_classes))
{
printf("%-20s : %5.5f\n", $class, $ref_classes->{$class} );
}
Si lo ejecuto en el terminal obtengo:
$ perl nbayes.pl
# classify: training data = 13 , K = 1
good : 0.33287
bad : 0.68883
Hasta luego,
Bruno
