File Coverage

blib/lib/Bio/Polloc/LocusI.pm

Criterion	Covered	Total	%
statement	121	199	60.8
branch	51	116	43.9
condition	16	59	27.1
subroutine	25	35	71.4
pod	28	28	100.0
total	241	437	55.1

=head1 NAME

Bio::Polloc::LocusI - Interface of C<Bio::Polloc::Locus::*> objects

=head1 AUTHOR - Luis M. Rodriguez-R

Email lmrodriguezr at gmail dot com

=head1 IMPLEMENTS OR EXTENDS

=over

=item *

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

=back

=cut

package Bio::Polloc::LocusI;
use strict;
use base qw(Bio::Polloc::Polloc::Root);
use Bio::Polloc::RuleI;
use Bio::Polloc::Polloc::IO;
use List::Util qw(min max);
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

=cut

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

   if($class !~ m/Bio::Polloc::Locus::(\S+)/){
      my $bme = Bio::Polloc::Polloc::Root->new(@args);
      my($type) = $bme->_rearrange([qw(TYPE)], @args);

      if($type){
         $type = Bio::Polloc::LocusI->_qualify_type($type);
         $class = "Bio::Polloc::Locus::" . $type if $type;
      }
   }

   if($class =~ m/Bio::Polloc::Locus::(\S+)/){
      my $load = 0;
      if(Bio::Polloc::RuleI->_load_module($class)){
         $load = $class;
      }elsif(Bio::Polloc::RuleI->_load_module("Bio::Polloc::Locus::generic")){
         $load = "Bio::Polloc::Locus::generic";
      }

      if($load){
         my $self = $load->SUPER::new(@args);
	 $self->debug("Got the LocusI class $load");
	 my($from,$to,$strand,$name,$rule,$seq,
	 	$id,$family,$source,$comments,$genome,$seqname) =
	 	$self->_rearrange(
	 	[qw(FROM TO STRAND NAME RULE SEQ ID FAMILY SOURCE COMMENTS GENOME SEQNAME)],
		@args);
	 $self->from($from);
	 $self->to($to);
	 $self->strand($strand);
	 $self->name($name);
	 $self->rule($rule);
	 $self->seq($seq);
	 $self->id($id);
	 $self->family($family);
	 $self->source($source);
	 $self->comments($comments);
	 $self->genome($genome);
	 $self->seq_name($seqname);
         $self->_initialize(@args);
         return $self;

      }

      my $bme = Bio::Polloc::Polloc::Root->new(@args);
      $bme->throw("Impossible to load the module", $class);
   }
   my $bme = Bio::Polloc::Polloc::Root->new(@args);
   $bme->throw("Impossible to load the proper Bio::Polloc::LocusI class with ".
   		"[".join("; ",@args)."]", $class);
}

=head2 type

Gets/sets the type of rule

B<Arguments>

Value (str).  Can be: pattern, profile, repeat, similarity, coding. composition, crispr
Some variations can be introduced, like case variations or short versions like B<patt>
or B<rep>.

B<Return>

Value (str).  The type of the rule, or null if undefined.  The value returned is undef
or a string from the above list, regardless of the input variations.

B<Throws>

L<Bio::Polloc::Polloc::Error> if an unsupported type is received.

=cut

sub type {
   my($self,$value) = @_;
   if($value){
      my $v = $self->_qualify_type($value);
      $self->throw("Attempting to set an invalid type of locus",$value) unless $v;
      $self->{'_type'} = $v;
   }
   return $self->{'_type'};
}

=head2 genome

Sets/gets the source genome as a L<Bio::Polloc::Genome> object.

B<Throws>

L<Bio::Polloc::Polloc::Error> if unexpected type.

=cut

sub genome {
   my($self,$value) = @_;
   $self->{'_genome'} = $value if defined $value;
   return unless defined $self->{'_genome'};
   $self->throw("Unexpected type of genome", $self->{'_genome'})
   	unless UNIVERSAL::can($self->{'_genome'},'isa')
	and $self->{'_genome'}->isa('Bio::Polloc::Genome');
   return $self->{'_genome'};
}

=head2 name

Sets/gets the name of the locus

B<Arguments>

Name (str), the name to set

B<Returns>

The name (str or undef)

=cut

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


=head2 aliases

Gets the alias names

B<Returns>

Aliases (arr reference or undef)

=cut

sub aliases { return shift->{'_aliases'}; }


=head2 add_alias

B<Arguments>

One or more alias names (str)

=cut

sub add_alias {
   my($self,@values) = @_;
   $self->{'_aliases'} ||= [];
   push(@{$self->{'_aliases'}}, @values);
}

=head2 parents

Gets the parent features or loci

B<Returns>

Parents (arr reference or undef)

=cut

sub parents { return shift->{'_parents'}; }

=head2 add_parent

B<Arguments>

One or more parent object (C<Bio::Polloc::LocusI>)

B<Throws>

L<Bio::Polloc::Polloc::Error> if some argument is not L<Bio::Polloc::LocusI>

=cut

sub add_parent {
   my($self,@values) = @_;
   $self->{'_parents'} ||= [];
   for(@values){ $self->throw("Illegal parent class '".ref($_)."'",$_)
   	unless $_->isa('Bio::Polloc::LocusI') }
   push(@{$self->{'_aliases'}}, @values);
}

=head2 target

Gets/sets the target of the alignment, if the feature is some alignment

B<Arguments>

=over

=item -id

The ID of the target sequence

=item -from

The start on the target sequence

=item -to

The end on the target sequence

=item -strand

The strand of the target sequence

=back

B<Returns>

A hash reference like C<{B<id>=E<gt>id, B<from>=E<gt>from, B<to>=E<gt>to,
B<strand>=E<gt>strand}>

=cut

sub target {
   my($self,@args) = @_;
   if($#args>=0){
      my($id,$from,$to,$strand) = $self->_rearrange([qw(ID FROM TO STRAND)], @args);
      $self->{'_target'} = {'id'=>$id, 'from'=>$from, 'to'=>$to, 'strand'=>$strand};
   }
   return $self->{'_target'};
}

=head2 comments

Gets/sets the comments on the locus, newline-separated

B<Arguments>

New comments to add (str)

B<Returns>

Comments (str)

=cut

sub comments {
   my($self,@comments) = @_;
   if($#comments>=0){
      $self->{'_comments'} ||= "";
      for(@comments) { $self->{'_comments'} .= "\n" . $_ if defined $_ }
      $self->{'_comments'} =~ s/^\n+//;
      $self->{'_comments'} =~ s/\n+$//; #<- Just in case it gets an empty comment
   }
   return $self->{'_comments'};
}

=head2 xrefs

Gets the cross references of the locus

B<Returns>

Array reference or undef

=cut

sub xrefs { return shift->{'_xrefs'} }

=head2 add_xref

Adds a cross reference

B<Arguments>

One or more cross references in GFF3 format

=cut

sub add_xref {
   my $self = shift;
   $self->{'_xrefs'} ||= [];
   push @{$self->{'_xrefs'}}, @_ if $#_>=0;
}

=head2 ontology_terms_str

Gets the ontology terms as explicit strings

B<Returns>

Array reference or undef

=cut

sub ontology_terms_str{ return shift->{'_ontology_terms_str'} }

=head2 add_ontology_term_str

Adds an ontology term by string

B<Arguments>

One or more strings

=cut

sub add_ontology_term_str {
   my $self = shift;
   push @{$self->{'_ontology_terms_str'}}, @_ if $#_>=0;
}


=head2 from

Gets/sets the B<from> position

B<Arguments>

Position (int, optional)

B<Returns>

The B<from> position (int, -1 if undefined)

=cut

sub from {
   my($self,$value) = @_;
   $self->{'_from'} ||= -1;
   $self->{'_from'} = $value+0 if defined $value;
   return $self->{'_from'};
}


=head2 to

Gets/sets the B<to> position

B<Arguments>

Position (int, optional)

B<Returns>

The B<to> position (int, -1 if undefined)

=cut

sub to {
   my($self,$value) = @_;
   $self->{'_to'} ||= -1;
   $self->{'_to'} = $value+0 if defined $value;
   return $self->{'_to'};
}

=head2 length

Gets the length of the locus.

B<Returns>

I<int> or C<undef>.

=cut

sub length {
   my $self = shift;
   return unless defined $self->from and defined $self->to;
   return abs($self->to - $self->from);
}

=head2 id

Gets/sets the ID of the locus

B<Arguments>

ID (str)

B<Returns>

ID (str)

=cut

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


=head2 family

Sets/gets the family of features.  I<I.e.>, a name identifying the type of locus.
A common family is B<CDS>, but other families can be defined.  Note that the family
is not qualified by the software used for the prediction (use C<source()> for that).

B<Arguments>

The family (str, optional)

B<Returns>

The family (str)

B<Note>

This method tries to locate the family by looking (in that order) at:

=over

=item 1

The explicitly defined family.

=item 2

The prefix of the ID (asuming it was produced by some L<Bio::Polloc::RuleI> object).

=item 3

The type of the rule (if the rule is defined).

=item 4

If any of the former options work, returns B<unknown>.

=back

=cut

sub family {
   my($self,$value) = @_;
   $self->{'_family'} = $value if defined $value;
   unless(defined $self->{'_family'} or not defined $self->id){
      if($self->id =~ m/(.*):\d+\.\d+/){
         $self->{'_family'} = $1;
      }
   }
   $self->{'_family'} = $self->rule->type if not defined $self->{'_family'} and defined $self->rule;
   return 'unknown' unless defined $self->{'_family'};
   return $self->{'_family'};
}

=head2 source

Sets/gets the source of the feature.  For example, the software used.

B<Arguments>

The source (str, optional).

B<Returns>

The source (str).

B<Note>

This method tries to locate the source looking (in that order) at:

=over

=item 1

The explicitly defined value.

=item 2

The source of the rule (if defined).

=item 3

If any of the above, returns B<polloc>.

=back

=cut

sub source {
   my($self,$value) = @_;
   $self->{'_source'} = $value if defined $value;
   $self->{'_source'} = $self->rule->source
   	if not defined $self->{'_source'} and defined $self->rule;
   return 'polloc' if not defined $self->{'_source'};
   return $self->{'_source'};
}

=head2 strand

Gets/sets the strand

B<Arguments>

Strand (str: B<+>, B<-> or B<.>)

B<Returns>

The strand (str)

=cut

sub strand {
   my($self,$value) = @_;
   $self->{'_strand'} ||= '.';
   $self->{'_strand'} = $value if defined $value;
   return $self->{'_strand'};
}

=head2 rule

Gets/sets the origin rule

B<Arguments>

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

B<Returns>

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

B<Throws>

L<Bio::Polloc::Polloc::Error> if the argument is not of the proper class

=cut

sub rule {
   my($self,$value) = @_;
   if(defined $value){
      $self->throw("Unexpected class of argument '".ref($value)."'",$value)
      		unless $value->isa('Bio::Polloc::RuleI');
      $self->{'_rule'} = $value;
   }
   return $self->{'_rule'};
}


=head2 score

Sets/gets the score of the feature.  Most loci implement
different score functions, and it's often read-only.

B<Returns>

The score (float)

B<Throws>

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

=cut

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

=head2 seq

Sets/gets the sequence

B<Arguments>

The sequence (Bio::Seq object, optional)

B<Returns>

The sequence (Bio::Seq object or undef)

B<Throws>

L<Bio::Polloc::Polloc::Error> if the sequence is not Bio::Seq

B<Note>

This method returns the full original sequence, not the piece of sequence with the target

=cut
sub seq {
   my($self,$seq) = @_;
   if(defined $seq){
      $self->throw("Illegal type of sequence", $seq)
      		unless UNIVERSAL::can($seq, 'isa') and $seq->isa('Bio::Seq');
      $self->{'_seq'} = $seq;
   }
   if(not defined $self->{'_seq'} and defined $self->{'_seq_name'} and defined $self->genome){
      $self->{'_seq'} = $self->genome->search_sequence($self->seq_name);
   }
   return $self->{'_seq'};
}

=head2 seq_name

Gets/sets the name of the sequence

B<Arguments>

The name of the sequence (str, optional).

B<Returns>

The name of the sequence (str or C<undef>).

=cut

sub seq_name {
   my($self, $value) = @_;
   $self->{'_seq_name'} = $value if defined $value;
   if(not defined $self->{'_seq_name'} and defined $self->seq){
      $self->{'_seq_name'} = $self->seq->display_id;
   }
   return $self->{'_seq_name'};
}

=head2 stringify

B<Purpose>

To provide an easy method for the (str) description of any L<Bio::Polloc::LocusI> object.

B<Returns>

The stringified object (str, off course)

=cut

sub stringify {
   my($self,@args) = @_;
   my $out = ucfirst $self->type;
   $out.= " '" . $self->id . "'" if defined $self->id;
   $out.= " at [". $self->from. "..". $self->to . $self->strand ."]";
   return $out;
}

=head2 context_seq

Extracts a sequence from the context of the locus

B<Arguments>

All the following arguments are mandatory, and must be passed in that order:

=over

=item *

ref I<int> :
  -1 to use the start as reference (useful for upstream sequences),
  +1 to use the end as reference (useful for downstream sequences),
   0 to use the start as start reference and the end as end reference

=item *

from I<int> : The relative start position.

=item *

to I<int> : The relative end position.

=back

B<Returns>

A L<Bio::Seq> object.

=cut

sub context_seq {
   my ($self, $ref, $from, $to) = @_;
   $self->_load_module('Bio::Polloc::GroupCriteria');
   return unless defined $self->seq and defined $self->from and defined $self->to;
   my $seq;
   my ($start, $end);
   my $revcom = 0;
   if($ref < 0){
      if($self->strand eq '?' or $self->strand eq '+'){
	 # (500..0)--------------->*[* >> ft >> ]
	 $start = $self->from - $from;	$end = $self->from - $to;
      }else{
	 # [ << ft << *]*<-----------------(500..0)
	 $start = $self->to + $to;	$end = $self->to + $from;	$revcom = !$revcom;
      }
   }elsif($ref > 0){
      if($self->strand eq '?' or $self->strand eq '+'){
	 # [ >> ft >> *]*<-----------------(500..0)
	 $start = $self->to + $to;	$end = $self->to + $from;	$revcom = !$revcom;
      }else{
	 # (500..0)--------------->*[* << ft << ]
	 $start = $self->from - $from;		$end = $self->from - $to;
      }
   }else{
      if($self->strand eq '?' or $self->strand eq '+'){
	 $start = $self->from + $from;	$end = $self->to + $from;
      }else{
	 $start = $self->to - $from;	$end = $self->from - $to;
      }
   }
   $start = max(1, $start);
   $end = min($self->seq->length, $end);
   $self->debug("Extracting context ".
   		(defined $self->seq->display_id?$self->seq->display_id:'').
		"[$start..$end] ".($revcom?"-":"+"));
   $seq = Bio::Polloc::GroupCriteria->_build_subseq($self->seq, $start, $end);
   return unless defined $seq;
   $seq = $seq->revcom if $revcom;
   return $seq;
}

=head2 distance

Calculates the distance (referring to diversity, not genomic position) with the
given locus.

B<Arguments>

=over

=item -locus I<Bio::Polloc::LocusI object>

The locus to compare with.  Most of the locus types require this locus to be of
the same type.

=item -locusref I<Bio::Polloc::LocusI object>

The reference locus.  If set, replaces the loaded object as reference.

=back

B<Returns>

Float.  The distance with the given locus.  Most types will return a distance ranging
from one to zero.

B<Note>

See the documentation for additional arguments and precisions.

B<Throws>

L<Bio::Polloc::Polloc::NotImplementedException> if not implemented by the correspondig class.

=cut

sub distance { $_[0]->throw("score",$_[0],"Bio::Polloc::Polloc::NotImplementedException") }


=head1 INTERNAL METHODS

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

=head2 _qualify_type

Uniformizes the distinct names that every type can receive

B<Arguments>

The requested type (str)

B<Returns>

The qualified type (str or undef)

=cut

sub _qualify_type {
   my($self,$value) = @_;
   return unless $value;
   $value = lc $value;
   $value = "pattern" if $value=~/^(patt(ern)?)$/;
   $value = "profile" if $value=~/^(prof(ile)?)$/;
   $value = "repeat" if $value=~/^(rep(eat)?)$/;
   $value = "similarity" if $value=~/^((sequence)?sim(ilarity)?|homology|ident(ity)?)$/;
   $value = "coding" if $value=~/^(cod|cds)$/;
   $value = "composition" if $value=~/^(comp(osition)?|content)$/;
   return $value;
   # TRUST IT! if $value =~ /^(pattern|profile|repeat|similarity|coding|composition|crispr)$/;
}

=head2 _initialize

=cut

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

1;