Naïve Bayes con pseudoconteos (Laplace)

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.

Figura recortada de http://www.sciencedirect.com/science/article/pii/S0092867404003046

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