lib/Bio/SeqIO/asciitree.pm

   1 #
   2 # BioPerl module for Bio::SeqIO::asciitree
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Chris Mungall <cjm@fruitfly.org>
   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<bioperl-l@bioperl.org>
  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
  84 use strict;
  85
  86
  87 use base qw(Bio::SeqIO);
  88
  89 sub _initialize {
  90     my($self,@args) = @_;
  91
  92     $self->SUPER::_initialize(@args);
  93     # hash for functions for decoding keys.
  94 }
  95
  96 =head2 show_detail
  97
  98  Title   : show_detail
  99  Usage   : $obj->show_detail($newval)
 100  Function:
 101  Example :
 102  Returns : value of show_detail (a scalar)
 103  Args    : on set, new value (a scalar or undef, optional)
 104
 105
 106 =cut
 107
 108 sub show_detail{
 109     my $self = shift;
 110
 111     return $self->{'show_detail'} = shift if @_;
 112     return $self->{'show_detail'};
 113 }
 114
 115
 116 =head2 next_seq
 117
 118  Title   : next_seq
 119  Usage   : $seq = $stream->next_seq()
 120  Function: returns the next sequence in the stream
 121  Returns : Bio::Seq object
 122  Args    :
 123
 124 =cut
 125
 126 sub next_seq {
 127     my ($self,@args) = @_;
 128     $self->throw("This is a WRITE-ONLY adapter");
 129 }
 130
 131
 132 =head2 write_seq
 133
 134  Title   : write_seq
 135  Usage   : $stream->write_seq($seq)
 136  Function: writes the $seq object (must be seq) to the stream
 137  Returns : 1 for success and 0 for error
 138  Args    : array of 1 to n Bio::SeqI objects
 139
 140 =cut
 141
 142 sub write_seq {
 143     my ($self,@seqs) = @_;
 144
 145     foreach my $seq ( @seqs ) {
 146         $self->throw("Attempting to write with no seq!") unless defined $seq;
 147
 148         if( ! ref $seq || ! $seq->isa('Bio::SeqI') ) {
 149             $self->warn(" $seq is not a SeqI compliant module. Attempting to dump, but may fail!");
 150         }
 151         $self->_print("Seq: ".$seq->accession_number);
 152         $self->_print("\n");
 153         my @top_sfs = $seq->get_SeqFeatures;
 154         $self->write_indented_sf(1, @top_sfs);
 155     }
 156 }
 157
 158 sub write_indented_sf {
 159     my $self = shift;
 160     my $indent = shift;
 161     my @sfs = @_;
 162     foreach my $sf (@sfs) {
 163         my $label = '';
 164         if ($sf->has_tag('standard_name')) {
 165             ($label) = $sf->get_tag_values('standard_name');
 166         }
 167         if ($sf->has_tag('product')) {
 168             ($label) = $sf->get_tag_values('product');
 169         }
 170         my $COLS = 60;
 171         my $tab = ' ' x 10;
 172         my @lines = ();
 173         if ($self->show_detail) {
 174             my @tags = $sf->all_tags;
 175             foreach my $tag (@tags) {
 176                 my @vals = $sf->get_tag_values($tag);
 177                 foreach my $val (@vals) {
 178                     $val = "\"$val\"";
 179                     push(@lines,
 180                          "$tab/$tag=");
 181                     while (my $cut =
 182                            substr($val, 0, $COLS - length($lines[-1]), '')) {
 183                         $lines[-1] .= "$cut";
 184                         if ($val) {
 185                             push(@lines, $tab);
 186                         }
 187                     }
 188                 }
 189             }
 190         }
 191         my $detail = join("\n", @lines);
 192
 193         my @sub_sfs = $sf->get_SeqFeatures;
 194         my $locstr = '';
 195         if (!@sub_sfs) {
 196             $locstr = $self->_locstr($sf);
 197         }
 198         my $col1 = sprintf("%s%s $label",
 199                            '  ' x $indent, $sf->primary_tag);
 200         my $line = sprintf("%-50s %s\n",
 201                            substr($col1, 0, 50), $locstr);
 202         $self->_print($line);
 203         if ($detail) {
 204             $self->_print($detail."\n");
 205         }
 206         $self->write_indented_sf($indent+1, @sub_sfs);
 207     }
 208     return;
 209 }
 210
 211 sub _locstr {
 212     my $self = shift;
 213     my $sf = shift;
 214     my $strand = $sf->strand || 0;
 215     my $ss = '.';
 216     $ss = '+' if $strand > 0;
 217     $ss = '-' if $strand < 0;
 218
 219     my $splitlocstr = '';
 220     if ($sf->isa("Bio::SeqFeatureI")) {
 221         my @locs = ($sf->location);
 222         if ($sf->location->isa("Bio::Location::SplitLocationI")) {
 223             @locs = $sf->location->each_Location;
 224             $splitlocstr = "; SPLIT: ".join(" ",
 225                                           map {$self->_locstr($_)} @locs);
 226
 227         }
 228     }
 229
 230     return
 231       sprintf("%d..%d[%s] $splitlocstr", $sf->start, $sf->end, $ss);
 232 }
 233
 234 1;