branch-1-6/Bio/Tools/FootPrinter.pm

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