Bio/Tools/FootPrinter.pm

   1 # BioPerl module for Bio::Tools::FootPrinter
   2 #
   3 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   4 #
   5 # Cared for by Shawn Hoon <shawnh@fugu-sg.org>
   6 #
   7 # Copyright Shawn Hoon
   8 #
   9 # You may distribute this module under the same terms as perl itself
  10
  11 # POD documentation - main docs before the code
  12
  13 =head1 NAME
  14
  15 Bio::Tools::FootPrinter - write sequence features in FootPrinter format
  16
  17 =head1 SYNOPSIS
  18
  19     use Bio::Tools::FootPrinter;
  20
  21     my $tool = Bio::Tools::FootPrinter->new(-file=>"footprinter.out");
  22
  23     while (my $result = $tool->next_feature){
  24       foreach my $feat($result->sub_SeqFeature){
  25         print $result->seq_id."\t".$feat->start."\t".$feat->end."\t".$feat->seq->seq."\n";
  26       }
  27     }
  28
  29 =head1 DESCRIPTION
  30
  31 This module writes sequence features in FootPrinter format.
  32 See L<http://bio.cs.washington.edu/software.html> for more details.
  33
  34 =head1 FEEDBACK
  35
  36 =head2 Mailing Lists
  37
  38 User feedback is an integral part of the evolution of this and other
  39 Bioperl modules. Send your comments and suggestions preferably to
  40 the Bioperl mailing list.  Your participation is much appreciated.
  41
  42   bioperl-l@bioperl.org                  - General discussion
  43   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  44
  45 =head2 Support
  46
  47 Please direct usage questions or support issues to the mailing list:
  48
  49 I<bioperl-l@bioperl.org>
  50
  51 rather than to the module maintainer directly. Many experienced and
  52 reponsive experts will be able look at the problem and quickly
  53 address it. Please include a thorough description of the problem
  54 with code and data examples if at all possible.
  55
  56 =head2 Reporting Bugs
  57
  58 Report bugs to the Bioperl bug tracking system to help us keep track
  59 of the bugs and their resolution. Bug reports can be submitted via the
  60 web:
  61
  62   https://github.com/bioperl/bioperl-live/issues
  63
  64 =head1 AUTHOR - Shawn Hoon
  65
  66 Email shawnh@fugu-sg.org
  67
  68 =head1 APPENDIX
  69
  70 The rest of the documentation details each of the object methods.
  71 Internal methods are usually preceded with a _
  72
  73 =cut
  74
  75
  76 # Let the code begin...
  77
  78
  79 package Bio::Tools::FootPrinter;
  80 use strict;
  81
  82 use Bio::SeqFeature::Generic;
  83 use Bio::PrimarySeq;
  84
  85 use base qw(Bio::Root::Root Bio::Root::IO);
  86
  87 =head2 new
  88
  89  Title   : new
  90  Usage   : my $obj = Bio::Tools::FootPrinter->new();
  91  Function: Builds a new Bio::Tools::FootPrinter object
  92  Returns : Bio::Tools::FootPrinter
  93  Args    : -fh/-file => $val, # for initing input, see Bio::Root::IO
  94
  95 =cut
  96
  97 sub new {
  98   my($class,@args) = @_;
  99
 100   my $self = $class->SUPER::new(@args);
 101   $self->_initialize_io(@args);
 102
 103   return $self;
 104 }
 105
 106 =head2 next_feature
 107
 108  Title   : next_feature
 109  Usage   : my $r = $footprint->next_feature
 110  Function: Get the next feature from parser data
 111  Returns : L<Bio::SeqFeature::Generic>
 112  Args    : none
 113
 114 =cut
 115
 116 sub next_feature{
 117    my ($self) = @_;
 118    $self->_parse_predictions() unless $self->_predictions_parsed();
 119    return shift @{$self->{'_feature'}};
 120
 121 }
 122
 123 =head2 _add_feature
 124
 125  Title   : _add_feature
 126  Usage   : $footprint->_add_feature($feat)
 127  Function: Add feature to array
 128  Returns : none
 129  Args    : none
 130
 131 =cut
 132
 133 sub _add_feature {
 134     my ($self,$feat) = @_;
 135     if($feat){
 136         push @{$self->{'_feature'}},$feat;
 137     }
 138 }
 139
 140 =head2 _parse_predictions
 141
 142  Title   : _parse_predictions
 143  Usage   : my $r = $footprint->_parse_predictions
 144  Function: do the parsing
 145  Returns : none
 146  Args    : none
 147
 148 =cut
 149
 150 sub _parse_predictions {
 151   my ($self) = @_;
 152   $/="";
 153   my ($seq,$second,$third,$name);
 154   while ($_ = $self->_readline) {
 155     chomp;
 156     my @array = split("\n",$_);
 157     if ($#array == 5) {
 158       # get rid of header
 159       shift(@array); shift(@array);
 160     }
 161     if($#array == 3){
 162         if($name){
 163             $name=~s/>//;
 164             my $feat = $self->_parse($name,$seq,$second,$third);
 165             $self->_add_feature($feat);
 166         }
 167         $name    = shift @array;
 168         $seq     = $array[0];
 169         $second  = $array[1];
 170         $third   = $array[2];
 171         next;
 172     }
 173     $seq        .= $array[0];
 174     $third      .= $array[2];
 175   }
 176
 177   $seq || return;
 178
 179   $name=~s/>//;
 180   my $feat = $self->_parse($name,$seq,$second,$third);
 181   $self->_add_feature($feat);
 182
 183   $self->_predictions_parsed(1);
 184 }
 185
 186 =head2 _predictions_parsed
 187
 188  Title   : _predictions_parsed
 189  Usage   : $footprint->_predictions_parsed(1)
 190  Function: Get/Set for whether predictions parsed
 191  Returns : 1/0
 192  Args    : none
 193
 194 =cut
 195
 196 sub _predictions_parsed {
 197     my ($self,$val) = @_;
 198     if($val){
 199         $self->{'_predictions_parsed'} = $val;
 200     }
 201     return $self->{'_predictions_parsed'};
 202 }
 203
 204
 205 =head2 _parse
 206
 207  Title   : _parse
 208  Usage   : $footprint->_parse($name,$seq,$pattern)
 209  Function: do the actual parsing
 210  Returns : L<Bio::SeqFeature::Generic>
 211  Args    : none
 212
 213 =cut
 214
 215 sub _parse {
 216     my ($self,$name,$seq,$score,$pattern) = @_;
 217     my @char  = split('',$pattern);
 218     my @score = split('',$score);
 219
 220     my ($prev,$word,@words,@word_scores,$word_score);
 221
 222     my $i = 0;
 223     for my $c ( @char ) {
 224         if( ! $word) {
 225             $word .= $c;
 226             $prev = $c;
 227             defined $score[$i] &&
 228                 ($score[$i] =~ /\d/) && ($word_score += $score[$i]);
 229         } elsif ($c eq $prev){
 230             $word .=$c;
 231             $prev  = $c;
 232             defined $score[$i] &&
 233                 ($score[$i] =~ /\d/) && ($word_score += $score[$i]);
 234         } else {
 235             # remove words with only \s
 236             $word=~s/\s+//g;
 237             if ($word ne ''){
 238                 push @words, $word;
 239                 push @word_scores, ($word_score/length($word));
 240             }
 241             $word =$c;
 242             $prev = $c;
 243             $word_score = 0;
 244             defined $score[$i] &&
 245                 ($score[$i] =~ /\d/) && ($word_score += $score[$i]);
 246         }
 247         $i++;
 248     }
 249     $word =~s/\s+//g;
 250     if( length($word) ){
 251         push @words, $word;
 252     }
 253     my $last;
 254     my $feat = Bio::SeqFeature::Generic->new(-seq_id=>$name);
 255     my $offset = $i = 0;
 256     my $count = 1;
 257     for my $w (@words){
 258         if(length($w) ) {
 259             my $index = index($pattern,$w,$offset);
 260             $offset = $index + length($w);
 261             my $subfeat = Bio::SeqFeature::Generic->new
 262                 ( -seq_id  =>"$name-motif".$count++,
 263                   -start   => $index+1,
 264                   -end     => $index+length($w),
 265                   -source  =>"FootPrinter",
 266                   -score   => $word_scores[$i]
 267                   );
 268             # ugh - not sure the sub_SeqFeature situation will
 269             # be around forever- things should probably be
 270             # grouped by a 'group' tag instead ala GFF3
 271             # perhaps when Lincoln's API changes are
 272             # made to SeqFeatures this will get changed
 273             $feat->add_sub_SeqFeature($subfeat,'EXPAND');
 274         }
 275         $i++;
 276     }
 277     my $priseq = Bio::PrimarySeq->new(-id=>$name,-seq=>$seq);
 278     $feat->attach_seq($priseq);
 279     return $feat;
 280
 281 }
 282
 283 1;