view release on metacpan or  search on metacpan

Bio/Matrix/PSM/ProtMatrix.pm  view on Meta::CPAN

sub get_array {
   my $self = shift;
   my $letter = uc(shift);

   $self->throw ("No such base: $letter!\n") unless grep { /$letter/ } @{$self->{_alphabet}};

   return @{$self->{"prob$letter"}}; 
}


=head2 get_logs_array

 Title    : get_logs_array
 Usage    :
 Function : Returns an array with log_odds for a specified base
 Throws   :
 Example  :
 Returns  : Array representing log-odds scores for specified amino acid.
 Args     : Single amino acid (character).

=cut

sub get_logs_array {
   my $self = shift;
   my $letter = uc(shift);

   $self->throw ("No such base: $letter!\n") unless grep { /$letter/ } @{$self->{_alphabet}};

   return @{$self->{"log$letter"}}; 
}

=head2 id

 Title    : id
 Usage    :
 Function : Gets/sets the site id
 Throws   :
 Example  :
 Returns  : string
 Args     : string

=cut

sub id {
      my $self = shift;
      if (@_) { $self->{id} = shift; }
      return $self->{id};
}

=head2 regexp

 Title    : regexp
 Usage    :
 Function : Returns a case-insensitive regular expression which matches the
            IUPAC convention.  X's in consensus sequence will match anything.     
 Throws   :
 Example  :
 Returns  : string
 Args     : Threshold for calculating consensus sequence (number in range 0-100
            representing a percentage). Threshold defaults to 20.

=cut

sub regexp {
   my $self = shift;
   my $threshold = 20;
   if ( @_ ) { my $threshold = shift };

   my @alphabet = @{$self->{_alphabet}};
   my $width = $self->width;
   my (@regexp, $i);
   for ( $i = 0; $i < $width; $i++ ) {
      # get an array of the residues at this position with p > $threshold
      my @letters = map { uc($_).lc($_) } grep { $self->{"prob$_"}->[$i] >= $threshold } @alphabet;

      my $reg;
      if ( scalar(@letters) == 0 ) {
         $reg = '\.';
      } else {
         $reg = '['.join('',@letters).']';
      }
      push @regexp, $reg;
   }

   if ( wantarray ) { 
      return @regexp;
   } else {
      return join '', @regexp;
   }
}


=head2 regexp_array

 Title    : regexp_array
 Usage    :
 Function : Returns an array of position-specific regular expressions.
             X's in consensus sequence will match anything.      
 Throws   :
 Example  :
 Returns  : Array of position-specific regular expressions.
 Args     : Threshold for calculating consensus sequence (number in range 0-100
            representing a percentage). Threshold defaults to 20.
 Notes    : Simply calls regexp method in list context.

=cut

sub regexp_array {
   my $self = shift;
   
   return @{ $self->regexp };
}


=head2 _compress_array

 Title    : _compress_array
 Usage    :
 Function :  Will compress an array of real signed numbers to a string (ie vector of bytes)
             -127 to +127 for bi-directional(signed) and 0..255 for unsigned ;
 Throws   :
 Example  :  Internal stuff
 Returns  :  String
 Args     :  array reference, followed by max value and direction (optional, defaults to 1),
             direction of 1 is unsigned, anything else is signed. 

=cut

sub _compress_array {
   my ($array,$lm,$direct)=@_;
   my $str;
   return unless(($array) && ($lm));
   $direct=1 unless ($direct);
   my $k1= ($direct==1) ? (255/$lm) : (127/$lm);
   foreach my $c (@{$array}) {
      $c=$lm if ($c>$lm);
      $c=-$lm if (($c<-$lm) && ($direct !=1));
      $c=0 if (($c<0) && ($direct ==1));
      my $byte=int($k1*$c);
      $byte=127+$byte if ($direct !=1);#Clumsy, should be really shift the bits
      my $char=chr($byte);
      $str.=$char;
   }
   return $str;
}

=head2 _uncompress_string

 Title    : _uncompress_string
 Usage    :
 Function :   Will uncompress a string (vector of bytes) to create an array of real
                  signed numbers (opposite to_compress_array)
 Throws   :
 Example  :   Internal stuff
 Returns  :   string, followed by max value and direction (optional, defaults to 1),
              direction of 1 is unsigned, anything else is signed.
 Args     :   array

=cut

sub _uncompress_string {
   my ($str,$lm,$direct)=@_;
   my @array;