File Coverage

blib/lib/Bio/Polloc/RuleIO.pm

Criterion	Covered	Total	%
statement	92	141	65.2
branch	37	64	57.8
condition	14	23	60.8
subroutine	18	24	75.0
pod	16	16	100.0
total	177	268	66.0

=head1 NAME

Bio::Polloc::RuleIO - I/O interface for the sets of rules (L<Bio::Polloc::RuleI>)

=head1 AUTHOR - Luis M. Rodriguez-R

Email lmrodriguezr at gmail dot com

=head1 IMPLEMENTS OR EXTENDS

=over

=item *

L<Bio::Polloc::Polloc::Root>

=item *

L<Bio::Polloc::Polloc::IO>

=back

=cut

package Bio::Polloc::RuleIO;
use strict;
use base qw(Bio::Polloc::Polloc::Root Bio::Polloc::Polloc::IO);
our $VERSION = 1.0503; # [a-version] from Bio::Polloc::Polloc::Version


=head1 PUBLIC METHODS

Methods provided by the package

=cut

=head2 new

The basic initialization method

B<Arguments>

The same arguments of L<Bio::Polloc::Polloc::IO>, plus:

=over

=item -format

The format of the file

=item -genomes

The genomes to be scaned

=back

=cut

sub new {
   my($caller,@args) = @_;
   my $class = ref($caller) || $caller;

   if($class !~ m/Bio::Polloc::RuleSet::(\S+)/){
      my $bme = Bio::Polloc::Polloc::Root->new(@args);
      my($format,$file) = $bme->_rearrange([qw(FORMAT FILE)], @args);

      ($format = $file) =~ s/.*\.// if $file and not $format;
      if($format){
         $format = Bio::Polloc::RuleIO->_qualify_format($format);
         $class = "Bio::Polloc::RuleSet::" . $format if $format;
      }
   }

   if($class =~ m/Bio::Polloc::RuleSet::(\S+)/){
      if(Bio::Polloc::RuleIO->_load_module($class)){;
         my $self = $class->SUPER::new(@args);
	 $self->debug("Got the RuleIO class $class ($1)");
	 $self->format($1);
	 my ($genomes) = $self->_rearrange([qw(GENOMES)], @args);
	 $self->genomes($genomes);
         $self->_initialize(@args);
         return $self;
      }
      my $bme = Bio::Polloc::Polloc::Root->new(@args);
      $bme->throw("Impossible to load the module", $class);
   } else {
      my $bme = Bio::Polloc::Polloc::Root->new(@args);
      $bme->throw("Impossible to load the proper Bio::Polloc::RuleIO class with [".
      		join("; ",@args)."]", $class);
   }
}

=head2 prefix_id

Sets/gets the prefix ID, unique for the RuleSet

B<Purpose>

To allow the identification of children in a unique namespace

B<Arguments>

A string, supposedly unique.  Any colon (:) will be changed to '_'

B<Returns>

The prefix ID.

=cut

sub prefix_id {
  my($self,$value) = @_;
  if(defined $value && "$value"){ #<- to avoid empty string ('') but allow zero (0)
     $value =~ s/:/_/g;
     $self->{'_prefix_id'} = "$value";
  }
  # Attempt to set from the parsed values if not explicitly setted
  $self->{'_prefix_id'} = $self->safe_value('prefix_id') unless defined $self->{'_prefix_id'};
  return $self->{'_prefix_id'};
}

=head2 init_id

=cut

sub init_id {
   my($self,$value) = @_;
   $self->{'_init_id'} = $value if defined $value;
   $self->{'_init_id'} ||= 1;
   return $self->{'_init_id'};
}

=head2 format

=cut

sub format {
   my($self,$value) = @_;
   $value = $self->_qualify_format($value);
   $self->{'_format'} = $value if $value;
   return $self->{'_format'};
}



=head2 add_rule

Appends rules to the rules set.

=head2 Arguments

One or more L<Bio::Polloc::RuleI> objects

=head2 Returns

The index of the last rule

=head2 Throws

A L<Bio::Polloc::Polloc::Error> exception if some object is not a L<Bio::Polloc::RuleI>

=cut

sub add_rule {
   my($self, @rules) = @_;
   return unless $#rules >= 0;
   $self->get_rules; #<- to initialize the array if does not exist
   for my $rule (@rules){
      $self->throw("Trying to add an illegal class of Rule", $rule)
      		unless $rule->isa('Bio::Polloc::RuleI');
      $rule->ruleset($self);
      push @{$self->{'_registered_rules'}}, $rule;
   }
   return $#{$self->{'_registered_rules'}};
}


=head2 get_rule

Gets the rule at the given index

B<Arguments>

The index (int)

B<Returns>

A L<Bio::Polloc::RuleI> object or undef

=cut

sub get_rule {
   my($self,$index) = @_;
   return unless defined $index;
   return if $index < 0;
   return if $index > $#{$self->get_rules};
   return $self->get_rules->[$index];
}

=head2 get_rules

=cut

sub get_rules {
   my($self, @args) = @_;
   $self->{'_registered_rules'} ||= [];
   return $self->{'_registered_rules'};
}

=head2 next_rule

B<Returns>

A L<Bio::Polloc::RuleI> object

=cut
sub next_rule {
   my($self, @args) = @_;
   my $rule = $self->get_rule($self->{'_loop_index_rules'} || 0);
   $self->{'_loop_index_rules'}++;
   $self->_end_rules_loop unless $rule;
   return $rule;
}

=head2 groupcriteria

Sets/gets the group criteria objects.

B<Arguments>

A L<Bio::Polloc::GroupCriteria> array ref (optional)

B<Returns>

A L<Bio::Polloc::GroupCriteria> array ref or undef

=cut

sub groupcriteria {
   my($self,$value) = @_;
   $self->{'_grouprules'} = $value if defined $value;
   return $self->{'_grouprules'};
}

=head2 grouprules

Alias of L<groupcriteria> (for backwards-compatibility).

=cut

sub grouprules { return shift->groupcriteria(@_) }

=head2 addgrouprules

Adds a grouprules object

B<Arguments>

A L<Bio::Polloc::GroupCriteria> object

B<Throws>

A L<Bio::Polloc::Polloc::Error> if not a proper object

=cut

sub addgrouprules {
   my($self,$value) = @_;
   $self->throw("Illegal grouprules object",$value) unless $value->isa("Bio::Polloc::GroupCriteria");
   $self->{'_grouprules'} = [] unless defined $self->{'_grouprules'};
   push @{$self->{'_grouprules'}}, $value;
}

=head2 execute

Executes the executable rules only over the whole list of genomes

B<Arguments>

Any argument supported/required by the rules, plus:

=over

=item -advance L<sub ref>

A reference to a method to be called to report the advance
of the execution.  The method must accept four arguments,
namely:

=over

=item 1

The number of loci detected so far

=item 2

The number of genomes scanned so far

=item 3

The total number of genomes to scan

=item 4

The ID of the running rule

=back

=back

B<Returns>

A L<Bio::Polloc::LociGroup> object.

=cut

sub execute {
   my($self, @args) = @_;
   $self->debug("Evaluating executable rules");
   my($advance) = $self->_rearrange([qw(ADVANCE)], @args);
   my $locigroup = Bio::Polloc::LociGroup->new(
   		-name=>'Full collection - '.time().".".rand(1000),
   		-genomes=>$self->genomes);
   $self->throw("Impossible to execute without genomes") unless defined $self->genomes;
   for my $gk (0 .. $#{$self->genomes}){
      my $genome = $self->genomes->[$gk];
      $self->_end_rules_loop;
      my $rulek = 0;
      while ( my $rule = $self->next_rule ){
         $rulek++;
	 $self->debug("On " . $self->{'_loop_index_rules'});
	 if($rule->executable){
	    $self->debug("RUN! on ".($#{$genome->get_sequences}+1)." sequences");
	    for my $seq (@{$genome->get_sequences}){
	       for my $locus (@{ $rule->execute(-seq=>$seq, @args) }){
	          $locus->genome($genome);
	          $locigroup->add_loci($locus);
	       }
	       &$advance($#{$locigroup->loci}+1, $gk+1, $#{$self->genomes}+1, $rulek)
	       		if defined $advance;
	    }
	 }
      }
      $self->_increase_index;
   }
   $self->debug("Got ".($#{$locigroup->loci}+1)." loci");
   return $locigroup;
}

=head2 safe_value

Sets/gets a parameter of arbitrary name and value

B<Purpose>

To provide a safe interface for setting values from the parsed file

B<Arguments>

=over

=item -param

The parameter's name (case insensitive)

=item -value

The value of the parameter (optional)

=back

B<Returns>

The value of the parameter or undef

=cut

sub safe_value {
   my ($self,@args) = @_;
   my($param,$value) = $self->_rearrange([qw(PARAM VALUE)], @args);
   $self->{'_values'} ||= {};
   return unless $param;
   $param = lc $param;
   if(defined $value){
      $self->{'_values'}->{$param} = $value;
   }
   return $self->{'_values'}->{$param};
}


=head2 parameter

B<Purpose>

Gets/sets some generic parameter.  It is intended to provide an
interface between L<Bio::Polloc::RuleIO>'s general configuration and
L<Bio::Polloc::RuleI>, regardless of the format.

B<Arguments>

The key (str) and the value (mix, optional)

B<Returns>

The value (mix or undef)

B<Throws>

A L<Bio::Polloc::Polloc::NotImplementedException> if not implemented

=cut

sub parameter {
   my $self = shift;
   $self->throw("parameter",$self,"Bio::Polloc::Polloc::NotImplementedException");
}

=head2 read

=cut

sub read {
   my $self = shift;
   $self->throw("read",$self,"Bio::Polloc::Polloc::NotImplementedException");
}

=head2 genomes

Gets/sets the genomes to be used as analysis base.

B<Arguments>

A reference to an array of L<Bio::Polloc::Genome> objects.

=cut

sub genomes {
   my($self, $value) = @_;
   $self->{'_genomes'} = $value if defined $value;
   return unless defined $self->{'_genomes'};
   $self->throw("Unexpected type of genomes collection", $self->{'_genomes'})
   	unless ref($self->{'_genomes'}) and ref($self->{'_genomes'})=~m/ARRAY/i;
   return $self->{'_genomes'};
}

=head1 INTERNAL METHODS

Methods intended to be used only within the scope of Bio::Polloc::*

=head2 _register_rule_parse

=cut

sub _register_rule_parse {
   my $self = shift;
   $self->throw("_register_rule_parse",$self,"Bio:Polloc::Polloc::NotImplementedException");
}

=head2 _increase_index

=cut

sub _increase_index {
   my $self = shift;
   while ( my $rule = $self->next_rule ){
      my $nid = $self->_next_child_id;
      $rule->id($nid) if defined $nid;
      $rule->restart_index;
   }
}

=head2 _next_child_id

=cut

sub _next_child_id {
   my $self = shift;
   return unless defined $self->prefix_id;
   $self->{'_next_child_id'} ||= $self->init_id;
   return $self->prefix_id . ":" . ($self->{'_next_child_id'}++);
}

=head2 _initialize

=cut

sub _initialize {
   my($self,@args) = @_;
   $self->throw("_initialize", $self, "Bio::Polloc::Polloc::NotImplementedException");
}

=head2 _qualify_format

=cut

sub _qualify_format {
   my($caller, $format) = @_;
   return unless $format;
   $format = lc $format;
   $format = "cfg" if $format =~ /^(conf|config|bme)$/;
   return $format if $format =~ /^(cfg)$/;
   return;
}

=head2 _end_rules_loop

=cut

sub _end_rules_loop { shift->{'_loop_index_rules'} = 0 }

1;