File Coverage

Bio/SeqIO/asciitree.pm
Criterion Covered Total %
statement 56 71 78.8
branch 17 26 65.3
condition 2 5 40.0
subroutine 7 8 87.5
pod 3 4 75.0
total 85 114 74.5


line stmt bran cond sub pod time code
1             #
2             # BioPerl module for Bio::SeqIO::asciitree
3             #
4             # Please direct questions and support issues to
5             #
6             # Cared for by Chris Mungall
7             #
8             # Copyright Chris Mungall
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::SeqIO::asciitree - asciitree sequence input/output stream
17              
18             =head1 SYNOPSIS
19              
20             # It is probably best not to use this object directly, but
21             # rather go through the SeqIO handler system. Go:
22              
23             $instream = Bio::SeqIO->new(-file => $filename,
24             -format => 'chadoxml');
25             $outstream = Bio::SeqIO->new(-file => $filename,
26             -format => 'asciitree');
27              
28             while ( my $seq = $instream->next_seq() ) {
29             $outstream->write_seq();
30             }
31              
32              
33             =head1 DESCRIPTION
34              
35             This is a WRITE-ONLY SeqIO module. It writes a Bio::SeqI object
36             containing nested SeqFeature objects in such a way that the SeqFeature
37             containment hierarchy is visible as a tree structure
38              
39              
40             =head1 FEEDBACK
41              
42             =head2 Mailing Lists
43              
44             User feedback is an integral part of the evolution of this and other
45             Bioperl modules. Send your comments and suggestions preferably to one
46             of the Bioperl mailing lists. Your participation is much appreciated.
47              
48             bioperl-l@bioperl.org - General discussion
49             http://bioperl.org/wiki/Mailing_lists - About the mailing lists
50              
51             =head2 Support
52              
53             Please direct usage questions or support issues to the mailing list:
54              
55             I
56              
57             rather than to the module maintainer directly. Many experienced and
58             reponsive experts will be able look at the problem and quickly
59             address it. Please include a thorough description of the problem
60             with code and data examples if at all possible.
61              
62             =head2 Reporting Bugs
63              
64             Report bugs to the Bioperl bug tracking system to help us keep track
65             the bugs and their resolution. Bug reports can be submitted via the web:
66              
67             https://github.com/bioperl/bioperl-live/issues
68              
69             =head1 AUTHOR - Chris Mungall
70              
71             Email cjm@fruitfly.org
72              
73             =head1 APPENDIX
74              
75             The rest of the documentation details each of the object
76             methods. Internal methods are usually preceded with a _
77              
78             =cut
79              
80             # Let the code begin...
81              
82             package Bio::SeqIO::asciitree;
83 1     1   4 use strict;
  1         2  
  1         32  
84              
85              
86 1     1   4 use base qw(Bio::SeqIO);
  1         1  
  1         733  
87              
88             sub _initialize {
89 1     1   2 my($self,@args) = @_;
90              
91 1         5 $self->SUPER::_initialize(@args);
92             # hash for functions for decoding keys.
93             }
94              
95             =head2 show_detail
96              
97             Title : show_detail
98             Usage : $obj->show_detail($newval)
99             Function:
100             Example :
101             Returns : value of show_detail (a scalar)
102             Args : on set, new value (a scalar or undef, optional)
103              
104              
105             =cut
106              
107             sub show_detail{
108 58     58 1 38 my $self = shift;
109              
110 58 50       75 return $self->{'show_detail'} = shift if @_;
111 58         80 return $self->{'show_detail'};
112             }
113              
114              
115             =head2 next_seq
116              
117             Title : next_seq
118             Usage : $seq = $stream->next_seq()
119             Function: returns the next sequence in the stream
120             Returns : Bio::Seq object
121             Args :
122              
123             =cut
124              
125             sub next_seq {
126 0     0 1 0 my ($self,@args) = @_;
127 0         0 $self->throw("This is a WRITE-ONLY adapter");
128             }
129              
130              
131             =head2 write_seq
132              
133             Title : write_seq
134             Usage : $stream->write_seq($seq)
135             Function: writes the $seq object (must be seq) to the stream
136             Returns : 1 for success and 0 for error
137             Args : array of 1 to n Bio::SeqI objects
138              
139             =cut
140              
141             sub write_seq {
142 1     1 1 52 my ($self,@seqs) = @_;
143              
144 1         4 foreach my $seq ( @seqs ) {
145 1 50       3 $self->throw("Attempting to write with no seq!") unless defined $seq;
146              
147 1 50 33     7 if( ! ref $seq || ! $seq->isa('Bio::SeqI') ) {
148 0         0 $self->warn(" $seq is not a SeqI compliant module. Attempting to dump, but may fail!");
149             }
150 1         10 $self->_print("Seq: ".$seq->accession_number);
151 1         2 $self->_print("\n");
152 1         5 my @top_sfs = $seq->get_SeqFeatures;
153 1         4 $self->write_indented_sf(1, @top_sfs);
154             }
155             }
156              
157             sub write_indented_sf {
158 59     59 0 35 my $self = shift;
159 59         41 my $indent = shift;
160 59         49 my @sfs = @_;
161 59         68 foreach my $sf (@sfs) {
162 58         43 my $label = '';
163 58 50       88 if ($sf->has_tag('standard_name')) {
164 0         0 ($label) = $sf->get_tag_values('standard_name');
165             }
166 58 100       80 if ($sf->has_tag('product')) {
167 37         53 ($label) = $sf->get_tag_values('product');
168             }
169 58         47 my $COLS = 60;
170 58         31 my $tab = ' ' x 10;
171 58         51 my @lines = ();
172 58 50       59 if ($self->show_detail) {
173 0         0 my @tags = $sf->all_tags;
174 0         0 foreach my $tag (@tags) {
175 0         0 my @vals = $sf->get_tag_values($tag);
176 0         0 foreach my $val (@vals) {
177 0         0 $val = "\"$val\"";
178 0         0 push(@lines,
179             "$tab/$tag=");
180 0         0 while (my $cut =
181             substr($val, 0, $COLS - length($lines[-1]), '')) {
182 0         0 $lines[-1] .= "$cut";
183 0 0       0 if ($val) {
184 0         0 push(@lines, $tab);
185             }
186             }
187             }
188             }
189             }
190 58         57 my $detail = join("\n", @lines);
191              
192 58         90 my @sub_sfs = $sf->get_SeqFeatures;
193 58         50 my $locstr = '';
194 58 50       82 if (!@sub_sfs) {
195 58         61 $locstr = $self->_locstr($sf);
196             }
197 58         123 my $col1 = sprintf("%s%s $label",
198             ' ' x $indent, $sf->primary_tag);
199 58         148 my $line = sprintf("%-50s %s\n",
200             substr($col1, 0, 50), $locstr);
201 58         113 $self->_print($line);
202 58 50       69 if ($detail) {
203 0         0 $self->_print($detail."\n");
204             }
205 58         90 $self->write_indented_sf($indent+1, @sub_sfs);
206             }
207 59         80 return;
208             }
209              
210             sub _locstr {
211 164     164   110 my $self = shift;
212 164         89 my $sf = shift;
213 164   50     236 my $strand = $sf->strand || 0;
214 164         128 my $ss = '.';
215 164 100       193 $ss = '+' if $strand > 0;
216 164 100       191 $ss = '-' if $strand < 0;
217              
218 164         98 my $splitlocstr = '';
219 164 100       373 if ($sf->isa("Bio::SeqFeatureI")) {
220 58         80 my @locs = ($sf->location);
221 58 100       75 if ($sf->location->isa("Bio::Location::SplitLocationI")) {
222 26         36 @locs = $sf->location->each_Location;
223             $splitlocstr = "; SPLIT: ".join(" ",
224 26         30 map {$self->_locstr($_)} @locs);
  106         125  
225              
226             }
227             }
228              
229             return
230 164         265 sprintf("%d..%d[%s] $splitlocstr", $sf->start, $sf->end, $ss);
231             }
232              
233             1;