File Coverage

Bio/SearchIO/Writer/ResultTableWriter.pm
Criterion Covered Total %
statement 84 123 68.2
branch 12 30 40.0
condition 0 3 0.0
subroutine 12 16 75.0
pod 5 8 62.5
total 113 180 62.7


line stmt bran cond sub pod time code
1              
2             =head1 NAME
3              
4             Bio::SearchIO::Writer::ResultTableWriter - Outputs tab-delimited data for each Bio::Search::Result::ResultI object.
5              
6             =head1 SYNOPSIS
7              
8             =head2 Example 1: Using the default columns
9              
10             use Bio::SearchIO;
11             use Bio::SearchIO::Writer::ResultTableWriter;
12              
13             my $in = Bio::SearchIO->new();
14              
15             my $writer = Bio::SearchIO::Writer::ResultTableWriter->new();
16              
17             my $out = Bio::SearchIO->new( -writer => $writer );
18              
19             while ( my $result = $in->next_result() ) {
20             $out->write_result($result, ($in->report_count - 1 ? 0 : 1) );
21             }
22              
23             =head2 Example 2: Specifying a subset of columns
24              
25             use Bio::SearchIO;
26             use Bio::SearchIO::Writer::ResultTableWriter;
27              
28             my $in = Bio::SearchIO->new();
29              
30             my $writer = Bio::SearchIO::Writer::ResultTableWriter->new(
31             -columns => [qw(
32             query_name
33             query_length
34             num_hits
35             )] );
36              
37             my $out = Bio::SearchIO->new( -writer => $writer,
38             -file => ">result.out" );
39              
40             while ( my $result = $in->next_result() ) {
41             $out->write_result($result, ($in->report_count - 1 ? 0 : 1) );
42             }
43              
44             =head2 Custom Labels
45              
46             You can also specify different column labels if you don't want to use
47             the defaults. Do this by specifying a C<-labels> hash reference
48             parameter when creating the ResultTableWriter object. The keys of the
49             hash should be the column number (left-most column = 1) for the label(s)
50             you want to specify. Here's an example:
51              
52             my $writer = Bio::SearchIO::Writer::ResultTableWriter->new(
53             -columns => [qw( query_name
54             query_length
55             query_description
56             num_hits)],
57             -labels => { 1 => 'QUERY_GI',
58             2 => 'QUERY_LENGTH' } );
59              
60              
61             =head1 DESCRIPTION
62              
63             Bio::SearchIO::Writer::ResultTableWriter outputs data in tab-delimited
64             format for each search result, one row per search result. This is a very
65             coarse-grain level of information since it only includes data
66             stored in the Bio::Search::Result::ResultI object itself and does not
67             include any information about hits or HSPs.
68              
69             You most likely will never use this object but instead will use one of
70             its subclasses: Bio::SearchIO::Writer::HitTableWriter or
71             Bio::SearchIO::Writer::HSPTableWriter.
72              
73             =head2 Available Columns
74              
75             Here are the columns that can be specified in the C<-columns>
76             parameter when creating a ResultTableWriter object. If a C<-columns> parameter
77             is not specified, this list, in this order, will be used as the default.
78              
79             query_name
80             query_length
81             query_description
82              
83             For more details about these columns, see the documentation for the
84             corresponding method in L.
85              
86             =head1 FEEDBACK
87              
88             =head2 Mailing Lists
89              
90             User feedback is an integral part of the evolution of this and other
91             Bioperl modules. Send your comments and suggestions preferably to one
92             of the Bioperl mailing lists. Your participation is much appreciated.
93              
94             bioperl-l@bioperl.org - General discussion
95             http://bioperl.org/wiki/Mailing_lists - About the mailing lists
96              
97             =head2 Support
98              
99             Please direct usage questions or support issues to the mailing list:
100              
101             I
102              
103             rather than to the module maintainer directly. Many experienced and
104             reponsive experts will be able look at the problem and quickly
105             address it. Please include a thorough description of the problem
106             with code and data examples if at all possible.
107              
108             =head2 Reporting Bugs
109              
110             Report bugs to the Bioperl bug tracking system to help us keep track
111             the bugs and their resolution. Bug reports can be submitted via the
112             web:
113              
114             https://github.com/bioperl/bioperl-live/issues
115              
116             =head1 AUTHOR
117              
118             Steve Chervitz Esac@bioperl.orgE
119              
120             See L for where to send bug reports
121             and comments.
122              
123             =head1 COPYRIGHT
124              
125             Copyright (c) 2001 Steve Chervitz. All Rights Reserved.
126              
127             This library is free software; you can redistribute it and/or modify
128             it under the same terms as Perl itself.
129              
130             =head1 DISCLAIMER
131              
132             This software is provided "as is" without warranty of any kind.
133              
134             =head1 SEE ALSO
135              
136             L,
137             L
138              
139             =head1 METHODS
140              
141             =cut
142              
143              
144             package Bio::SearchIO::Writer::ResultTableWriter;
145              
146 2     2   9 use strict;
  2         2  
  2         50  
147              
148 2     2   5 use base qw(Bio::Root::Root Bio::SearchIO::SearchWriterI);
  2         2  
  2         557  
149              
150             # Array fields: column, object, method[/argument], printf format, column label
151             # Methods are defined in Bio::Search::Result::ResultI.
152             # Tech note: If a bogus method is supplied, it will result in all values to be zero.
153             # Don't know why this is.
154             my %column_map = (
155             'query_name' => ['1', 'result', 'query_name', 's', 'QUERY' ],
156             'query_length' => ['2', 'result', 'query_length', 'd', 'LEN_Q'],
157             'query_description' => ['3', 'result', 'query_description', 's', 'DESC_Q'],
158             'num_hits' => ['4', 'result', 'num_hits', 'd', 'NUM_HITS'],
159             );
160              
161 0     0 0 0 sub column_map { return %column_map }
162              
163             sub new {
164 2     2 1 6 my ($class, @args) = @_;
165 2         10 my $self = $class->SUPER::new(@args);
166              
167 2         11 my( $col_spec, $label_spec,
168             $filters ) = $self->_rearrange( [qw(COLUMNS
169             LABELS
170             FILTERS)], @args);
171            
172 2         12 $self->_set_cols( $col_spec );
173 2 50       4 $self->_set_labels( $label_spec ) if $label_spec;
174 2         9 $self->_set_printf_fmt();
175 2         10 $self->_set_row_data_func();
176 2         9 $self->_set_column_labels();
177            
178 2 50       10 if( defined $filters ) {
179 0 0       0 if( !ref($filters) =~ /HASH/i ) {
180 0         0 $self->warn("Did not provide a hashref for the FILTERS option, ignoring.");
181             } else {
182 0         0 while( my ($type,$code) = each %{$filters} ) {
  0         0  
183 0         0 $self->filter($type,$code);
184             }
185             }
186             }
187              
188              
189 2         6 return $self;
190             }
191              
192              
193             # Purpose : Stores the column spec internally. Also performs QC on the
194             # user-supplied column specification.
195             #
196             sub _set_cols {
197 2     2   4 my ($self, $col_spec_ref) = @_;
198 2 50       11 return if defined $self->{'_cols'}; # only set columns once
199              
200 2         9 my %map = $self->column_map;
201              
202 2 50       9 if( not defined $col_spec_ref) {
203 0         0 print STDERR "\nUsing default column map.\n";
204 0         0 $col_spec_ref = [ map { $_ } sort { $map{$a}->[0] <=> $map{$b}->[0] } keys %map ];
  0         0  
  0         0  
205             }
206              
207 2 50       7 if( ref($col_spec_ref) eq 'ARRAY') {
208             # printf "%d columns to process\n", scalar(@$col_spec_ref);
209 2         4 my @col_spec = @{$col_spec_ref};
  2         6  
210 2         7 while( my $item = shift @col_spec ) {
211 15         12 $item = lc($item);
212 15 50       23 if( not defined ($map{$item}) ) {
213 0         0 $self->throw(-class =>'Bio::Root::BadParameter',
214             -text => "Unknown column name: $item"
215             );
216             }
217 15         12 push @{$self->{'_cols'}}, $item;
  15         34  
218             #print "pushing on to col $col_num, $inner: $item\n";
219             }
220             }
221             else {
222 0         0 $self->throw(-class =>'Bio::Root::BadParameter',
223             -text => "Can't set columns: not a ARRAY ref",
224             -value => $col_spec_ref
225             );
226             }
227             }
228              
229             sub _set_printf_fmt {
230 2     2   4 my ($self) = @_;
231              
232 2         8 my @cols = $self->columns();
233 2         6 my %map = $self->column_map;
234              
235 2         6 my $printf_fmt = '';
236              
237 2         7 foreach my $col ( @cols ) {
238 15         24 $printf_fmt .= "\%$map{$col}->[3]\t";
239             }
240              
241 2         4 $printf_fmt =~ s/\\t$//;
242              
243 2         7 $self->{'_printf_fmt'} = $printf_fmt;
244             }
245              
246 2     2 0 4 sub printf_fmt { shift->{'_printf_fmt'} }
247              
248             # Sets the data to be used for the labels.
249             sub _set_labels {
250 0     0   0 my ($self, $label_spec) = @_;
251 0 0       0 if( ref($label_spec) eq 'HASH') {
252 0         0 foreach my $col ( sort { $a <=> $b } keys %$label_spec ) {
  0         0  
253             # print "LABEL: $col $label_spec->{$col}\n";
254 0         0 $self->{'_custom_labels'}->{$col} = $label_spec->{$col};
255             }
256             }
257             else {
258 0         0 $self->throw(-class =>'Bio::Root::BadParameter',
259             -text => "Can't set labels: not a HASH ref: $label_spec"
260             );
261             }
262             }
263              
264             sub _set_column_labels {
265 2     2   2 my $self = shift;
266              
267 2         6 my @cols = $self->columns;
268 2         6 my %map = $self->column_map;
269 2         5 my $printf_fmt = '';
270 2         4 my (@data, $label, @underbars);
271              
272 2         2 my $i = 0;
273 2         5 foreach my $col( @cols ) {
274 15         10 $i++;
275 15         13 $printf_fmt .= "\%s\t";
276              
277 15 50       21 if(defined $self->{'_custom_labels'}->{$i}) {
278 0         0 $label = $self->{'_custom_labels'}->{$i};
279             }
280             else {
281 15         17 $label = $map{$col}->[4];
282             }
283 15         10 push @data, $label;
284 15         19 push @underbars, '-' x length($label);
285              
286             }
287 2         3 $printf_fmt =~ s/\\t$//;
288              
289 2         14 my $str = sprintf "$printf_fmt\n", @data;
290              
291 2         5 $str =~ s/\t\n/\n/;
292 2         10 $str .= sprintf "$printf_fmt\n", @underbars;
293              
294 2         5 $str =~ s/\t\n/\n/gs;
295 2         8 $self->{'_column_labels'} = $str;
296             }
297              
298             # Purpose : Generate a function that will call the appropriate
299             # methods on the result, hit, and hsp objects to retrieve the column data
300             # specified in the column spec.
301             #
302             # We should only have to go through the column spec once
303             # for a given ResultTableWriter. To permit this, we'll generate code
304             # for a method that returns an array of the data for a row of output
305             # given a result, hit, and hsp object as arguments.
306             #
307             sub _set_row_data_func {
308 2     2   3 my $self = shift;
309              
310             # Now we need to generate a string that can be eval'd to get the data.
311 2         6 my @cols = $self->columns();
312 2         7 my %map = $self->column_map;
313 2         5 my @data;
314 2         8 while( my $col = shift @cols ) {
315 15         17 my $object = $map{$col}->[1];
316 15         16 my $method = $map{$col}->[2];
317 15         11 my $arg = '';
318 15 100       28 if( $method =~ m!(\w+)/(\w+)! ) {
319 2         5 $method = $1;
320 2         8 $arg = "\"$2\"";
321             }
322 15         35 push @data, "\$$object->$method($arg)";
323             }
324 2         6 my $code = join( ",", @data);
325              
326 2 50       7 if( $self->verbose > 0 ) {
327             ## Begin Debugging
328 0         0 $self->debug( "Data to print:\n");
329 0         0 foreach( 0..$#data) { $self->debug( " [". ($_+ 1) . "] $data[$_]\n");}
  0         0  
330 0         0 $self->debug( "CODE:\n$code\n");
331 0         0 $self->debug("Printf format: ". $self->printf_fmt. "\n");
332             ## End Debugging
333             }
334              
335             my $func = sub {
336 41     41   40 my ($result, $hit, $hsp) = @_;
337 41         2858 my @r = eval $code;
338             # This should reduce the occurrence of those opaque "all zeros" bugs.
339 41 50       137 if( $@ ) { $self->throw("Trouble in ResultTableWriter::_set_row_data_func() eval: $@\n\n");
  0         0  
340             }
341 41         142 return @r;
342 2         12 };
343 2         9 $self->{'_row_data_func'} = $func;
344             }
345              
346 2     2 0 5 sub row_data_func { shift->{'_row_data_func'} }
347              
348              
349             =head2 to_string()
350              
351             Note: this method is not intended for direct use. The
352             SearchIO::write_result() method calls it automatically if the writer
353             is hooked up to a SearchIO object as illustrated in L.
354              
355             Title : to_string()
356             :
357             Usage : print $writer->to_string( $result_obj, [$include_labels] );
358             :
359             Argument : $result_obj = A Bio::Search::Result::ResultI object
360             : $include_labels = boolean, if true column labels are included (default: false)
361             :
362             Returns : String containing tab-delimited set of data for each hit
363             : in a ResultI object. Some data is summed across multiple HSPs.
364             :
365             Throws : n/a
366              
367             =cut
368              
369             #----------------
370             sub to_string {
371             #----------------
372 0     0 1 0 my ($self, $result, $include_labels) = @_;
373              
374 0 0       0 my $str = $include_labels ? $self->column_labels() : '';
375 0         0 my $resultfilter = $self->filter('RESULT');
376 0 0 0     0 if( ! defined $resultfilter ||
377 0         0 &{$resultfilter}($result) ) {
378 0         0 my @row_data = &{$self->{'_row_data_func'}}( $result );
  0         0  
379 0         0 $str .= sprintf "$self->{'_printf_fmt'}\n", @row_data;
380 0         0 $str =~ s/\t\n/\n/gs;
381             }
382 0         0 return $str;
383             }
384              
385              
386              
387             sub columns {
388 6     6 1 8 my $self = shift;
389 6         5 my @cols;
390 6 50       11 if( ref $self->{'_cols'} ) {
391 6         7 @cols = @{$self->{'_cols'}};
  6         15  
392             }
393             else {
394 0         0 my %map = $self->column_map;
395 0         0 @cols = sort { $map{$a}->[0] <=> $map{$b}->[0] } keys %map;
  0         0  
396             }
397 6         17 return @cols;
398             }
399              
400              
401             =head2 column_labels
402              
403             Usage : print $result_obj->column_labels();
404             Purpose : Get column labels for to_string().
405             Returns : String containing column labels. Tab-delimited.
406             Argument : n/a
407             Throws : n/a
408              
409             =cut
410              
411 2     2 1 6 sub column_labels { shift->{'_column_labels'} }
412              
413             =head2 end_report
414              
415             Title : end_report
416             Usage : $self->end_report()
417             Function: The method to call when ending a report, this is
418             mostly for cleanup for formats which require you to
419             have something at the end of the document. Nothing for
420             a text message.
421             Returns : string
422             Args : none
423              
424             =cut
425              
426             sub end_report {
427 0     0 1   return '';
428             }
429              
430             =head2 filter
431              
432             Title : filter
433             Usage : $writer->filter('hsp', \&hsp_filter);
434             Function: Filter out either at HSP,Hit,or Result level
435             Returns : none
436             Args : string => data type,
437             CODE reference
438              
439              
440             =cut
441              
442              
443             # Is this really needed?
444             #=head2 signif_format
445             #
446             # Usage : $writer->signif_format( [FMT] );
447             # Purpose : Allows retrieval of the P/Expect exponent values only
448             # : or as a two-element list (mantissa, exponent).
449             # Usage : $writer->signif_format('exp');
450             # : $writer->signif_format('parts');
451             # Returns : String or '' if not set.
452             # Argument : String, FMT = 'exp' (return the exponent only)
453             # : = 'parts'(return exponent + mantissa in 2-elem list)
454             # : = undefined (return the raw value)
455             # Comments : P/Expect values are still stored internally as the full,
456             # : scientific notation value.
457             #
458             #=cut
459             #
460             ##-------------
461             #sub signif_format {
462             ##-------------
463             # my $self = shift;
464             # if(@_) { $self->{'_signif_format'} = shift; }
465             # return $self->{'_signif_format'};
466             #}
467              
468             1;