Bio/Tools/Prints.pm

   1 #
   2 # BioPerl module for Bio::Tools::Prints
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by  Balamurugan Kumarasamy
   7 #
   8 # You may distribute this module under the same terms as perl itself
   9 # POD documentation - main docs before the code
  10 #
  11
  12 =head1 NAME
  13
  14 Bio::Tools::Prints - Parser for FingerPRINTScanII program
  15
  16 =head1 SYNOPSIS
  17
  18   use Bio::Tools::Prints;
  19   my $prints_parser = Bio::Tools::Prints->new(-fh =>$filehandle );
  20   while( my $prints_feat = $prints_parser->next_result ) {
  21         push @prints_feat, $prints_feat;
  22   }
  23
  24 =head1 DESCRIPTION
  25
  26  PRINTScan II is a PRINTS fingerprint identification algorithm.
  27  Copyright (C) 1998,1999  Phil Scordis
  28
  29 =head1 FEEDBACK
  30
  31 =head2 Mailing Lists
  32
  33  User feedback is an integral part of the evolution of this and other
  34  Bioperl modules. Send your comments and suggestions preferably to
  35  the Bioperl mailing list.  Your participation is much appreciated.
  36
  37   bioperl-l@bioperl.org                  - General discussion
  38   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  39
  40 =head2 Support
  41
  42 Please direct usage questions or support issues to the mailing list:
  43
  44 I<bioperl-l@bioperl.org>
  45
  46 rather than to the module maintainer directly. Many experienced and
  47 reponsive experts will be able look at the problem and quickly
  48 address it. Please include a thorough description of the problem
  49 with code and data examples if at all possible.
  50
  51 =head2 Reporting Bugs
  52
  53  Report bugs to the Bioperl bug tracking system to help us keep track
  54  of the bugs and their resolution. Bug reports can be submitted via
  55  the web:
  56
  57   https://github.com/bioperl/bioperl-live/issues
  58
  59 =head1 AUTHOR - Balamurugan Kumarasamy
  60
  61  bala@tll.org.sg
  62  juguang@tll.org.sg
  63
  64 =head1 APPENDIX
  65
  66  The rest of the documentation details each of the object methods.
  67  Internal methods are usually preceded with a _
  68
  69
  70 =cut
  71
  72 package Bio::Tools::Prints;
  73 use strict;
  74
  75 use Bio::SeqFeature::FeaturePair;
  76 use Bio::SeqFeature::Generic;
  77 use base qw(Bio::Root::Root Bio::Root::IO);
  78
  79
  80 =head2 new
  81
  82  Title   : new
  83  Usage   : my $obj = Bio::Tools::Prints->new(-fh=>$filehandle);
  84  Function: Builds a new Bio::Tools::Prints object
  85  Returns : Bio::Tools::Prints
  86  Args    : -filename
  87            -fh (filehandle)
  88
  89 =cut
  90
  91 sub new {
  92       my($class,@args) = @_;
  93
  94       my $self = $class->SUPER::new(@args);
  95       $self->_initialize_io(@args);
  96
  97       return $self;
  98 }
  99
 100
 101 =head2 next_result
 102
 103  Title   : next_result
 104  Usage   : my $feat = $prints_parser->next_result
 105  Function: Get the next result set from parser data
 106  Returns : L<Bio::SeqFeature::Generic>
 107  Args    : none
 108
 109 =cut
 110
 111 sub next_result {
 112     my ($self) = @_;
 113     my %printsac;
 114     my @features;
 115     my $line;
 116     my $sequenceId;
 117
 118     while ($_=$self->_readline()) {
 119
 120            $line = $_;
 121            chomp $line;
 122
 123            if ($line =~ s/^Sn;//) { # We have identified a Sn; line so there should be the following:
 124
 125               ($sequenceId) = $line =~ /^\s*(\w+)/;
 126               $self->seqname($sequenceId);
 127               next;
 128            }
 129
 130            if ($line =~ s/^1TBH//) {
 131                my  ($id) = $line =~ /^\s*(\w+)/;
 132                my ($ac) = $line =~ /(PR\w+)\s*$/;
 133                $printsac{$id} = $ac;
 134                $self->print_sac(\%printsac);
 135                next;
 136            }
 137
 138            if ($line =~ s/^3TB//) {
 139
 140               if ($line =~ s/^[HN]//) {
 141                    my($num)="";
 142                    $line =~ s/^\s+//;
 143
 144                    my @elements = split /\s+/, $line;
 145
 146                    my ($fingerprintName,$motifNumber,$temp,$tot,$percentageIdentity,$profileScore,$pvalue,$subsequence,$motifLength,$lowestMotifPosition,$matchPosition,$highestMotifPosition) = @elements;
 147
 148                    my $start = $matchPosition;
 149                    my $end = $matchPosition + $motifLength - 1;
 150                    my $print_sac = $self->print_sac;
 151
 152                    my %printsac =  %{$print_sac};
 153                    my $print =  $printsac{$fingerprintName};
 154                    my $seqname=$self->seqname;
 155                    my $feat = "$print,$start,$end,$percentageIdentity,$profileScore,$pvalue";
 156                    my $new_feat =  $self->create_feature($feat,$seqname);
 157                    return $new_feat;
 158                }
 159                if ($line =~ s/^F//) {
 160                    return;
 161                }
 162                    next;
 163                }
 164             next;
 165
 166       }
 167
 168 }
 169
 170 =head2 create_feature
 171
 172  Title   : create_feature
 173  Usage   : my $feat=$prints_parser->create_feature($feature,$seqname)
 174  Function: creates a SeqFeature Generic object
 175  Returns : L<Bio::SeqFeature::FeaturePair>
 176  Args    :
 177
 178
 179 =cut
 180
 181 sub create_feature {
 182     my ($self, $feat,$sequenceId) = @_;
 183
 184     my @f = split (/,/,$feat);
 185     # create feature object
 186     my $feature= Bio::SeqFeature::Generic->new(
 187         -seq_id    =>$sequenceId,
 188         -start=>$f[1],
 189         -end  => $f[2],
 190         -score      => $f[4],
 191         -source     => "PRINTS",
 192         -primary    =>$f[0],
 193         -logic_name => "PRINTS",
 194     );
 195     $feature->add_tag_value('evalue',$f[5]);
 196     $feature->add_tag_value('percent_id',$f[3]);
 197
 198     my $feature2 = Bio::SeqFeature::Generic->new(
 199         -seq_id => $f[0],
 200         -start => 0,
 201         -end => 0,
 202     );
 203     my $fp = Bio::SeqFeature::FeaturePair->new(
 204         -feature1 => $feature,
 205         -feature2 => $feature2
 206     );
 207     return  $fp;
 208 }
 209
 210 =head2 print_sac
 211
 212  Title   : print_sac
 213  Usage   : $prints_parser->print_sac($print_sac)
 214  Function: get/set for print_sac
 215  Returns :
 216  Args    :
 217
 218
 219 =cut
 220
 221 sub print_sac {
 222     my $self = shift;
 223     return $self->{'print_sac'} = shift if @_;
 224     return $self->{'print_sac'};
 225 }
 226
 227 =head2 seqname
 228
 229  Title   : seqname
 230  Usage   : $prints_parser->seqname($seqname)
 231  Function: get/set for seqname
 232  Returns :
 233  Args    :
 234
 235
 236 =cut
 237
 238 sub seqname {
 239     my($self,$seqname)=@_;
 240     return $self->{'seqname'}=$seqname if(defined($seqname));
 241     return $self->{'seqname'};
 242 }
 243
 244 1;