← Back to branch summary

~ubuntu-branches/ubuntu/karmic/bioperl/karmic

« back to all changes in this revision

Viewing changes to Bio/Matrix/IO/scoring.pm

  • Committer: Bazaar Package Importer
  • Author(s): Matt Hope
  • Date: 2004-04-18 14:24:11 UTC
  • mfrom: (1.2.1 upstream) (2.1.1 warty)
  • Revision ID: james.westby@ubuntu.com-20040418142411-gr92uexquw4w8liq
Tags: 1.4-1
* New upstream release
* Examples and working code are installed by default to usr/bin,
  this has been moved to usr/share/doc/bioperl/bin

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/Matrix/IO/scoring.pm
 
1
# $Id: scoring.pm,v 1.1 2003/08/08 20:23:17 jason Exp $
 
2
#
 
3
# BioPerl module for Bio::Matrix::IO::scoring
 
4
#
 
5
# Cared for by Jason Stajich <jason-at-bioperl-dot-org>
 
6
#
 
7
# Copyright Jason Stajich
 
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::Matrix::IO::scoring - A parser for PAM/BLOSUM matricies
 
16
 
 
17
=head1 SYNOPSIS
 
18
 
 
19
  use Bio::Matrix::IO;
 
20
  my $parser = new Bio::Matrix::IO(-format => 'scoring',
 
21
                                   -file   => 'BLOSUM50');
 
22
  my $matrix = $parser->next_matrix;
 
23
 
 
24
=head1 DESCRIPTION
 
25
 
 
26
Describe the object here
 
27
 
 
28
=head1 FEEDBACK
 
29
 
 
30
=head2 Mailing Lists
 
31
 
 
32
User feedback is an integral part of the evolution of this and other
 
33
Bioperl modules. Send your comments and suggestions preferably to
 
34
the Bioperl mailing list.  Your participation is much appreciated.
 
35
 
 
36
  bioperl-l@bioperl.org              - General discussion
 
37
  http://bioperl.org/MailList.shtml  - About the mailing lists
 
38
 
 
39
=head2 Reporting Bugs
 
40
 
 
41
Report bugs to the Bioperl bug tracking system to help us keep track
 
42
of the bugs and their resolution. Bug reports can be submitted via
 
43
the web:
 
44
 
 
45
  http://bugzilla.bioperl.org/
 
46
 
 
47
=head1 AUTHOR - Jason Stajich
 
48
 
 
49
Email jason-at-bioperl-dot-org
 
50
 
 
51
Describe contact details here
 
52
 
 
53
=head1 CONTRIBUTORS
 
54
 
 
55
Additional contributors names and emails here
 
56
 
 
57
=head1 APPENDIX
 
58
 
 
59
The rest of the documentation details each of the object methods.
 
60
Internal methods are usually preceded with a _
 
61
 
 
62
=cut
 
63
 
 
64
 
 
65
# Let the code begin...
 
66
 
 
67
 
 
68
package Bio::Matrix::IO::scoring;
 
69
use vars qw(@ISA);
 
70
use strict;
 
71
 
 
72
# Object preamble - inherits from Bio::Root::Root
 
73
 
 
74
use Bio::Matrix::IO;
 
75
use Bio::Matrix::Scoring
 
76
 
 
77
@ISA = qw(Bio::Matrix::IO);
 
78
 
 
79
=head2 new
 
80
 
 
81
 Title   : new
 
82
 Usage   : my $obj = new Bio::Matrix::IO::scoring();
 
83
 Function: Builds a new Bio::Matrix::IO::scoring object 
 
84
 Returns : an instance of Bio::Matrix::IO::scoring
 
85
 Args    :
 
86
 
 
87
 
 
88
=cut
 
89
 
 
90
=head2 next_matrix
 
91
 
 
92
 Title   : next_matrix
 
93
 Usage   : my $matrux = $parser->next_matrix
 
94
 Function: parses a scoring matrix (BLOSUM,PAM styles) 
 
95
 Returns : L<Bio::Matrix::Scoring>
 
96
 Args    : none
 
97
 
 
98
 
 
99
=cut
 
100
 
 
101
sub next_matrix{
 
102
   my ($self) = @_;
 
103
   local ($_);
 
104
   my (@matrix,@cols,@rows,%extras,$inmatrix);
 
105
   while( defined ( $_ = $self->_readline ) ) {
 
106
       next if ( /^\s*$/);
 
107
       if( /^\#/ ) {
 
108
           if( $inmatrix ) { 
 
109
               $self->_pushback($_);
 
110
               last;
 
111
           }
 
112
           if( m/Entropy\s+\=\s+(\S+)\,\s+
 
113
               Expected\s+\=\s+(\S+)/ox ) {
 
114
               $extras{'-entropy'} = $1;
 
115
               $extras{'-expected'} = $2;
 
116
           } elsif ( m/Expected\s+score\s+\=\s+(\S+)\,
 
117
                     \s+Entropy\s+\=\s+(\S+)/xo ){
 
118
               $extras{'-entropy'} = $2;
 
119
               $extras{'-expected'} = $1;
 
120
           } elsif( m/(PAM\s+\d+)\s+substitution.+
 
121
                    scale\s+\=\s+(\S+)\s+\=\s+(\S+)/ox ) {
 
122
               $extras{'-matrix_name'} = $1;
 
123
               $extras{'-scale'}       = $2;           
 
124
               $extras{'-scale_value'} = $3;
 
125
           } elsif( /Blocks Database\s+\=\s+(\S+)/o ) {
 
126
               $extras{'-database'} = $1;
 
127
           } elsif( m/(\S+)\s+Bit\s+Units/ox ) {
 
128
               $extras{'-scale'} = $1;
 
129
           } elsif( m/Lowest score\s+\=\s+(\S+)\,\s+
 
130
                    Highest score\s+\=\s+(\S+)/ox ) {
 
131
               $extras{'-lowest_score'} = $1;
 
132
               $extras{'-highest_score'} = $2;
 
133
           } elsif( m/(Lambda)\s+\=\s+(\S+)\s+bits\,
 
134
                    \s+(H)\s+\=\s+(\S+)/ox ) {
 
135
               # This is a DNA matrix
 
136
               $extras{$1} = $2;
 
137
               $extras{$3} = $4;
 
138
           }           
 
139
       } elsif( s/^\s+(\S+)/$1/ ) {
 
140
           @cols = split;
 
141
           if( $cols[0] ne 'A' ) {
 
142
               $self->warn("Unrecognized first line of matrix, we might not have parsed it correctly");
 
143
           }
 
144
           $inmatrix = 1;
 
145
       } elsif( $inmatrix ) {
 
146
           if( ! /^(\S+)/ ) { $inmatrix = 0; next }
 
147
           my ($rowname,@row) = split;
 
148
           push @rows, $rowname;
 
149
           push @matrix, [@row];
 
150
       } else { 
 
151
           print;
 
152
       }
 
153
   }
 
154
   my $matrix = new Bio::Matrix::Scoring(-values     => \@matrix,
 
155
                                         -rownames   => \@rows,
 
156
                                         -colnames   => \@cols,
 
157
                                         %extras);
 
158
}
 
159
 
 
160
=head2 write_matrix
 
161
 
 
162
 Title   : write_matrix
 
163
 Usage   : $matio->write_matrix($matrix)
 
164
 Function: Write out a matrix in the BLOSUM/PAM format
 
165
 Returns : none
 
166
 Args    : L<Bio::Matrix::Scoring>
 
167
 
 
168
 
 
169
=cut
 
170
 
 
171
sub write_matrix{
 
172
   my ($self,@args) = @_;
 
173
   $self->warn("cannot actually use this function yet - it isn't finished");
 
174
   return undef;
 
175
}
 
176
 
 
177
 
 
178
1;