← Back to branch summary

~ubuntu-branches/ubuntu/saucy/bioperl/saucy-proposed

« back to all changes in this revision

Viewing changes to Bio/TreeIO/pag.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2009-03-10 07:19:11 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20090310071911-fukqzw54pyb1f0bd
Tags: 1.6.0-2
https://launchpad.net/bugs/324001
* Removed patch system (not used):
  - removed instuctions in debian/rules;
  - removed quilt from Build-Depends in debian/control.
* Re-enabled tests:
  - uncommented test command in debian/rules;
  - uncommented previously missing build-dependencies in debian/control.
  - Re-enabled tests and uncommented build-dependencies accordingly.
* Removed libmodule-build-perl and libtest-harness-perl from
  Build-Depends-Indep (provided by perl-modules).
* Better cleaning of empty directories using find -type d -empty -delete
  instead of rmdir in debian/rules (LP: #324001).

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/TreeIO/pag.pm
1
 
# $Id: pag.pm,v 1.9.4.1 2006/10/02 23:10:37 sendu Exp $
 
1
# $Id: pag.pm 14582 2008-03-01 17:28:31Z cjfields $
2
2
#
3
3
# BioPerl module for Bio::TreeIO::pag
4
4
#
65
65
 
66
66
 
67
67
package Bio::TreeIO::pag;
68
 
use vars qw($TaxonNameLen);
69
68
use strict;
70
69
 
71
 
$TaxonNameLen = 10;
 
70
our $TaxonNameLen = 10;
72
71
 
73
72
use base qw(Bio::TreeIO);
74
73
 
75
74
=head2 new
76
75
 
77
76
 Title   : new
78
 
 Usage   : my $obj = new Bio::TreeIO::pag();
 
77
 Usage   : my $obj = Bio::TreeIO::pag->new();
79
78
 Function: Builds a new Bio::TreeIO::pag object 
80
79
 Returns : an instance of Bio::TreeIO::pag
81
80
 Args    : -file/-fh for filename or filehandles
 
81
           -name_length for minimum name length (default = 10)
82
82
 
83
83
=cut
84
84
 
 
85
sub _initialize {
 
86
    my $self = shift;
 
87
    $self->SUPER::_initialize(@_);
 
88
    my ( $name_length ) = $self->_rearrange(
 
89
        [
 
90
            qw(NAME_LENGTH)
 
91
        ],
 
92
        @_
 
93
    );
 
94
    $self->name_length( defined $name_length ? $name_length : $TaxonNameLen );
 
95
}
85
96
 
86
97
=head2 write_tree
87
98
 
109
120
        $special_node, 
110
121
        $outgroup_ancestor,
111
122
        $tree_no) = (0,0,1);
 
123
    my $name_len = $self->name_length;
112
124
    if( @args ) {
113
125
        ($no_outgroups,
114
126
         $print_header,
115
127
         $special_node, 
116
128
         $outgroup_ancestor,
117
129
         $tree_no,
118
 
         $keep_outgroup) = $self->_rearrange([qw(NO_OUTGROUPS
 
130
         $keep_outgroup) = $self->_rearrange([qw(
 
131
                         NO_OUTGROUPS
119
132
                                                 PRINT_HEADER
120
133
                                                 SPECIAL_NODE
121
134
                                                 OUTGROUP_ANCESTOR
122
135
                                                 TREE_NO
123
 
                                                 KEEP_OUTGROUP)],@args);
 
136
                                                 KEEP_OUTGROUP
 
137
                         NAME_LENGTH)],@args);
124
138
    }
125
139
    my $newname_base = 1;
126
140
 
140
154
            $species_ct++;
141
155
 
142
156
            my $node_name = $node->id;
143
 
            if( length($node_name)> $TaxonNameLen ) {
144
 
                $self->warn( "Found a taxon name longer than $TaxonNameLen letters, \n",
 
157
            if( length($node_name)> $name_len ) {
 
158
                $self->warn( "Found a taxon name longer than $name_len letters, \n",
145
159
                             "name will be abbreviated.\n");
146
 
                $node_name = substr($node_name, 0,$TaxonNameLen);
 
160
                $node_name = substr($node_name, 0,$name_len);
147
161
            } else { 
148
162
                # $node_name = sprintf("%-".$TaxonNameLen."s",$node_name);
149
163
            }
176
190
    foreach my $node (@nodes) {
177
191
        my $i = 0;
178
192
        foreach my $anc (@ancestors) {
179
 
            if ($node eq $anc) { $i = 1; last }
 
193
            if ($anc && $node eq $anc) { $i = 1; last }
180
194
        }
181
195
        unless ($i > 0) {       # root not given in PAG
182
196
            my $current_name = $names{$node->internal_id};
225
239
   $self->throw_not_implemented();
226
240
}
227
241
 
 
242
=head2 name_length
 
243
 
 
244
 Title   : name_length
 
245
 Usage   : $self->name_length(20);
 
246
 Function: set mininum taxon name length
 
247
 Returns : integer (length of name)
 
248
 Args    : integer
 
249
 
 
250
=cut
 
251
 
 
252
sub name_length {
 
253
    my ($self, $val) = @_;
 
254
    return $self->{'name_len'} = $val if $val;
 
255
    return $self->{'name_len'};
 
256
}
228
257
 
229
258
1;