lib/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
  74 use strict;
  75
  76 use Bio::SeqFeature::FeaturePair;
  77 use Bio::SeqFeature::Generic;
  78 use base qw(Bio::Root::Root Bio::Root::IO);
  79
  80
  81 =head2 new
  82
  83  Title   : new
  84  Usage   : my $obj = Bio::Tools::Prints->new(-fh=>$filehandle);
  85  Function: Builds a new Bio::Tools::Prints object
  86  Returns : Bio::Tools::Prints
  87  Args    : -filename
  88            -fh (filehandle)
  89
  90 =cut
  91
  92 sub new {
  93       my($class,@args) = @_;
  94
  95       my $self = $class->SUPER::new(@args);
  96       $self->_initialize_io(@args);
  97
  98       return $self;
  99 }
 100
 101
 102 =head2 next_result
 103
 104  Title   : next_result
 105  Usage   : my $feat = $prints_parser->next_result
 106  Function: Get the next result set from parser data
 107  Returns : L<Bio::SeqFeature::Generic>
 108  Args    : none
 109
 110 =cut
 111
 112 sub next_result {
 113     my ($self) = @_;
 114     my %printsac;
 115     my @features;
 116     my $line;
 117     my $sequenceId;
 118
 119     while ($_=$self->_readline()) {
 120
 121            $line = $_;
 122            chomp $line;
 123
 124            if ($line =~ s/^Sn;//) { # We have identified a Sn; line so there should be the following:
 125
 126               ($sequenceId) = $line =~ /^\s*(\w+)/;
 127               $self->seqname($sequenceId);
 128               next;
 129            }
 130
 131            if ($line =~ s/^1TBH//) {
 132                my  ($id) = $line =~ /^\s*(\w+)/;
 133                my ($ac) = $line =~ /(PR\w+)\s*$/;
 134                $printsac{$id} = $ac;
 135                $self->print_sac(\%printsac);
 136                next;
 137            }
 138
 139            if ($line =~ s/^3TB//) {
 140
 141               if ($line =~ s/^[HN]//) {
 142                    my($num)="";
 143                    $line =~ s/^\s+//;
 144
 145                    my @elements = split /\s+/, $line;
 146
 147                    my ($fingerprintName,$motifNumber,$temp,$tot,$percentageIdentity,$profileScore,$pvalue,$subsequence,$motifLength,$lowestMotifPosition,$matchPosition,$highestMotifPosition) = @elements;
 148
 149                    my $start = $matchPosition;
 150                    my $end = $matchPosition + $motifLength - 1;
 151                    my $print_sac = $self->print_sac;
 152
 153                    my %printsac =  %{$print_sac};
 154                    my $print =  $printsac{$fingerprintName};
 155                    my $seqname=$self->seqname;
 156                    my $feat = "$print,$start,$end,$percentageIdentity,$profileScore,$pvalue";
 157                    my $new_feat =  $self->create_feature($feat,$seqname);
 158                    return $new_feat;
 159                }
 160                if ($line =~ s/^F//) {
 161                    return;
 162                }
 163                    next;
 164                }
 165             next;
 166
 167       }
 168
 169 }
 170
 171 =head2 create_feature
 172
 173  Title   : create_feature
 174  Usage   : my $feat=$prints_parser->create_feature($feature,$seqname)
 175  Function: creates a SeqFeature Generic object
 176  Returns : L<Bio::SeqFeature::FeaturePair>
 177  Args    :
 178
 179
 180 =cut
 181
 182 sub create_feature {
 183     my ($self, $feat,$sequenceId) = @_;
 184
 185     my @f = split (/,/,$feat);
 186     # create feature object
 187     my $feature= Bio::SeqFeature::Generic->new(
 188         -seq_id    =>$sequenceId,
 189         -start=>$f[1],
 190         -end  => $f[2],
 191         -score      => $f[4],
 192         -source     => "PRINTS",
 193         -primary    =>$f[0],
 194         -logic_name => "PRINTS",
 195     );
 196     $feature->add_tag_value('evalue',$f[5]);
 197     $feature->add_tag_value('percent_id',$f[3]);
 198
 199     my $feature2 = Bio::SeqFeature::Generic->new(
 200         -seq_id => $f[0],
 201         -start => 0,
 202         -end => 0,
 203     );
 204     my $fp = Bio::SeqFeature::FeaturePair->new(
 205         -feature1 => $feature,
 206         -feature2 => $feature2
 207     );
 208     return  $fp;
 209 }
 210
 211 =head2 print_sac
 212
 213  Title   : print_sac
 214  Usage   : $prints_parser->print_sac($print_sac)
 215  Function: get/set for print_sac
 216  Returns :
 217  Args    :
 218
 219
 220 =cut
 221
 222 sub print_sac {
 223     my $self = shift;
 224     return $self->{'print_sac'} = shift if @_;
 225     return $self->{'print_sac'};
 226 }
 227
 228 =head2 seqname
 229
 230  Title   : seqname
 231  Usage   : $prints_parser->seqname($seqname)
 232  Function: get/set for seqname
 233  Returns :
 234  Args    :
 235
 236
 237 =cut
 238
 239 sub seqname {
 240     my($self,$seqname)=@_;
 241     return $self->{'seqname'}=$seqname if(defined($seqname));
 242     return $self->{'seqname'};
 243 }
 244
 245 1;