File Coverage

Bio/AlignIO/arp.pm
Criterion Covered Total %
statement 70 74 94.5
branch 27 36 75.0
condition 1 3 33.3
subroutine 7 8 87.5
pod 2 2 100.0
total 107 123 86.9


line stmt bran cond sub pod time code
1             #
2             # BioPerl module for Bio::AlignIO::arp
3             #
4             # Copyright Chris Fields
5             #
6             # You may distribute this module under the same terms as perl itself
7             # POD documentation - main docs before the code
8              
9             =head1 NAME
10              
11             Bio::AlignIO::arp - ARP MSA Sequence input/output stream
12              
13             =head1 SYNOPSIS
14              
15             Do not use this module directly. Use it via the L
16             class.
17              
18             =head1 DESCRIPTION
19              
20             This object can create L objects from
21             ARP flat files. These are typically configuration-like data files
22             for the program Arlequin. For more information, see:
23              
24             http://lgb.unige.ch/arlequin/
25              
26             For the moment, this retains the allele sequence data in the DATA section and
27             inserts them into SimpleAlign objects. ARP files that contain other data (RFLP,
28             etc.) are not expected to parse properly. Also, if the DNA data is actually SNP
29             data, then the LocatableSeq object instantiation will throw an error.
30              
31             This is now set up as a generic parser (i.e. it parses everything) and
32             collects as much data as possible into the SimpleAlign object. The following
33             in a general mapping of where data can be found:
34              
35             Tag SimpleAlign
36             Method
37             ----------------------------------------------------------------------
38             Title description
39             SampleName id
40             ----------------------------------------------------------------------
41              
42             Tag Bio::Annotation TagName Bio::Annotation
43             Class Parameters
44             ----------------------------------------------------------------------
45             NE SimpleValue pfam_family_accession value
46             NL SimpleValue sequence_start_stop value
47             SS SimpleValue sec_structure_source value
48             BM SimpleValue build_model value
49             RN Reference reference *
50             ----------------------------------------------------------------------
51             * RN is generated based on the number of Bio::Annotation::Reference objects
52              
53             In addition, the number of samples found in the alignment is retained in a
54             Bio::Annotation::TagTree object in the annotation collection and is accessible
55             via:
56              
57             ($samples) = $aln->annotation->get_Annotations('Samples');
58             say $samples->display_text;
59             # or use other relevant TagTree methods to retrieve data
60              
61             =head1 FEEDBACK
62              
63             =head2 Support
64              
65             Please direct usage questions or support issues to the mailing list:
66              
67             I
68              
69             rather than to the module maintainer directly. Many experienced and
70             reponsive experts will be able look at the problem and quickly
71             address it. Please include a thorough description of the problem
72             with code and data examples if at all possible.
73              
74             =head2 Reporting Bugs
75              
76             Report bugs to the Bioperl bug tracking system to help us keep track
77             the bugs and their resolution. Bug reports can be submitted via the
78             web:
79              
80             https://github.com/bioperl/bioperl-live/issues
81              
82             =head1 AUTHORS
83              
84             Chris Fields (cjfields)
85              
86             =head1 APPENDIX
87              
88             The rest of the documentation details each of the object
89             methods. Internal methods are usually preceded with a _
90              
91             =cut
92              
93             # Let the code begin...
94              
95             package Bio::AlignIO::arp;
96 2     2   530 use strict;
  2         2  
  2         56  
97 2     2   6 use base qw(Bio::AlignIO);
  2         2  
  2         412  
98              
99 2     2   10 use Data::Dumper;
  2         3  
  2         103  
100 2     2   561 use Bio::Annotation::AnnotationFactory;
  2         3  
  2         1384  
101              
102             =head2 next_aln
103              
104             Title : next_aln
105             Usage : $aln = $stream->next_aln
106             Function: returns the next alignment in the stream.
107             Returns : Bio::Align::AlignI object - returns 0 on end of file
108             or on error
109             Args : -width => optional argument to specify the width sequence
110             will be written (60 chars by default)
111              
112             See L
113              
114             =cut
115              
116             sub next_aln {
117 5     5 1 746 my $self = shift;
118 5         30 my $aln = Bio::SimpleAlign->new(-source => 'arp');
119 5         7 my ($data, $cur_block, $cur_type, $cur_data);
120             SCAN:
121 5         21 while (defined ($data = $self->_readline) ) {
122 209 100       587 next if $data =~ m{^\s*$}xms;
123 195 100       602 if ($data =~ m{\[{1,2}(\w+)\]{1,2}}xms) {
    100          
    100          
124 9         17 $self->{state}->{current_block} = $1;
125 9         18 next SCAN;
126             }
127             elsif ($data =~ m{^\s*(\w+)=\s?(\S[^\n]*$)}xms) {
128 32         53 ($cur_type, $cur_data) = ($1, $2);
129 32 100       51 if ($cur_data =~ m{^\s*\{\s*$}) {
130             $self->throw("Curly block must be embedded in a named Block")
131 5 50       9 if !exists($self->{state}->{current_block});
132 5         6 $self->{state}->{in_curly_block} = 1;
133 5         11 next SCAN;
134             }
135 27         45 $cur_data =~ s{[\"\']}{}g;
136 27         61 $cur_data =~ s{\s*$}{};
137             # per alignment annotation data (i.e. Sample Blocks) or
138             # annotation data retained for each alignment?
139             $self->{state}->{current_block} eq 'Samples' ?
140 10         32 push @{$self->{state}->{SampleAnnotation}->{$cur_type}}, $cur_data :
141 27 100       45 push @{$self->{state}->{Annotation}->{$cur_type}}, $cur_data;
  17         50  
142             }
143             elsif ($data =~ m{^\s*\}\s*$}xms) {
144             $self->throw("Unmatched bracket in ARP file:\n$data") if
145 5 50       13 !exists($self->{state}->{in_curly_block});
146 5 50       10 if ($self->{state}->{current_block} eq 'Samples') {;
147 5         11 my $ac = $self->_process_annotation($aln);
148 5         17 delete $self->{state}->{SampleAnnotation};
149             } else {
150             # process other data at a later point
151             }
152 5         4 delete $self->{state}->{blockdata};
153 5         6 $self->{state}->{in_curly_block} = 0;
154 5         8 last SCAN;
155             }
156             else {
157             # all other data should be in a curly block and have a block title
158             $self->throw("Data found outside of proper block:\n$data") if
159 149 0 33     246 !exists($self->{state}->{current_block}) && !$self->{state}->{in_curly_block};
160             # bypass commented stuff (but we may want to process it at a later
161             # point, so turn back here)
162 149 100       246 next if $data =~ m{^\s*\#}xms;
163 137 50       215 if ($self->{state}->{current_block} eq 'Samples') {
164 137         126 chomp $data;
165             # we have two possible ways to deal with sample number, either
166             # clone the LocatableSeq (in which case we need to deal with ID
167             # duplication), or store as annotation data. I chose the latter
168             # route using a Bio::Annotation::TagTree. YMMV - cjfields 10-15-08
169 137         189 my ($ls, $samples) = $self->_process_sequence($data);
170 137         241 my $id = $ls->id;
171 137         104 push @{ $self->{state}->{SampleAnnotation}->{Samples} }, [$id => $samples];
  137         299  
172 137         359 $aln->add_seq($ls);
173             } else {
174             # add elsif's for further processing
175             #$self->debug('Unmatched data in block '.
176             # $self->{state}->{current_block}.
177             # ":\n$data\n");
178 0         0 $self->{state}->{blockdata} .= $data;
179             }
180             }
181             }
182             # alignments only returned if they contain sequences
183 5 50       13 return $aln if $aln->num_sequences;
184 0         0 return;
185             }
186              
187             =head2 write_aln
188              
189             Title : write_aln
190             Usage : $stream->write_aln(@aln)
191             Function: writes the $aln object into the stream in xmfa format
192             Returns : 1 for success and 0 for error
193             Args : L object
194              
195             See L
196              
197             =cut
198              
199             sub write_aln {
200 0     0 1 0 my ($self,@aln) = @_;
201 0         0 $self->throw_not_implemented;
202             }
203              
204             ################ PRIVATE SUBS ################
205              
206             sub _process_sequence {
207 137     137   143 my ($self, $raw) = @_;
208 137 50       187 return unless defined $raw;
209 137         4325 $raw =~ s{(?:^\s+|\s+$)}{}g;
210 137         324 my ($id, $samples, $seq) = split(' ', $raw);
211 137         291 my $ls = Bio::LocatableSeq->new('-seq' => $seq,
212             '-start' => 1,
213             '-display_id' => $id,
214             '-alphabet' => $self->alphabet);
215 137         235 return($ls, $samples);
216             }
217              
218             sub _process_annotation {
219 5     5   6 my ($self, $aln) = @_;
220 5         28 my $coll = Bio::Annotation::Collection->new();
221 5         23 my $factory = Bio::Annotation::AnnotationFactory->new(-type => 'Bio::Annotation::SimpleValue');
222 5         7 for my $anntype (qw(SampleAnnotation Annotation)) {
223 10         9 for my $key (keys %{ $self->{state}->{$anntype} }) {
  10         30  
224 42 100       77 if ($key eq 'Title') {
    100          
    100          
225 5         16 $aln->description($self->{state}->{$anntype}->{$key}[0]);
226             } elsif ($key eq 'Samples') {
227 5         9 $factory->type('Bio::Annotation::TagTree');
228             $coll->add_Annotation($key, $factory->create_object(
229 5         21 -value => [$key => $self->{state}->{$anntype}->{$key}]));
230 5         13 $factory->type('Bio::Annotation::SimpleValue');
231             } elsif ($key eq 'SampleName') {
232 5         18 $aln->id($self->{state}->{$anntype}->{$key}[0]);
233             } else {
234             $self->throw('Expecting an array reference') unless
235 27 50       55 ref $self->{state}->{$anntype}->{$key} eq 'ARRAY';
236 27         21 for my $a (@{ $self->{state}->{$anntype}->{$key} }) {
  27         36  
237 27         59 $coll->add_Annotation($key, $factory->create_object(
238             -value => $a) );
239             }
240             }
241             }
242             }
243             #$self->debug("Collection:".Dumper($coll)."\n");
244 5         14 $aln->annotation($coll);
245             }
246              
247             1;