Skip to content

Commit

Permalink
Merge remote branch 'upstream/master' into topic/tree_dbsqlite_memoryfix
Browse files Browse the repository at this point in the history
  • Loading branch information
@hyphaltip
hyphaltip committed Nov 9, 2010
2 parents 86c901a + dd7a316 commit 1e21af8
Show file tree
Hide file tree
Showing 17 changed files with 873 additions and 704 deletions.
2 changes: 1 addition & 1 deletion Bio/Tree/NodeNHX.pm
View file
Expand Up @@ -134,7 +134,7 @@ sub to_string{
my ($self) = @_;
my @tags = $self->get_all_tags;
my $tagstr = '';
if( @tags ) {
if( scalar(@tags) > 0 ) {
$tagstr = '[' . join(":", "&&NHX",
map { "$_=" .join(',',
$self->get_tag_values($_))}
Expand Down
42 changes: 11 additions & 31 deletions Bio/Tree/Tree.pm
View file
Expand Up @@ -375,41 +375,21 @@ sub score{
sub as_text {
my $self = shift;
my $format = shift;
my @parms;
my $params_input = shift || {};

my $iomod = "Bio::TreeIO::$format";
$self->_load_module($iomod);
# following currently not really necessary, but who knows?
my $io = $iomod->new(-format=>$format, -file=>File::Spec->devnull());
no strict "refs";
my $iowtH = *{$iomod."::_write_tree_Helper"}{CODE};
use strict "refs";
for ($format) {
/newick/ && do {
@parms = ( $io->bootstrap_style, $io->order_by, 0 );
last;
};
/nhx/ && do {
@parms = ( 0 );
last;
};
/tabtree/ && do {
@parms = ( "" );
last;
};
# default
$self->throw("as_text does not allow format '$format'")
}


# newline_each_node...
my $data = [$iowtH->($self->get_root_node, @parms)];
my $string = '';
open(my $fh,">",\$string) or die ("Couldn't open $string as file: $!\n");
my $test = $iomod->new(-format=>$format,-fh=>$fh);

if ($format eq 'tabtree') {
return $$data[0]."\n";
}
else {
return join(",", @$data).";\n";
}
# Get the default params for the given IO module.
$test->set_params($params_input);

$test->write_tree($self);
close($fh);
return $string;
}

=head2 Methods for associating Tag/Values with a Tree
Expand Down
5 changes: 2 additions & 3 deletions Bio/Tree/TreeFunctionsI.pm
View file
Expand Up @@ -637,7 +637,7 @@ sub force_binary {
if (@descs > 2) {
$self->warn("Node ".($node->can('node_name') ? ($node->node_name || $node->id) : $node->id).
" has more than two descendants\n(".
join(", ", map { $node->can('node_name') ? ($node->node_name || $node->id) : $node->id } @descs).
join(", ", map { $node->can('node_name') ? ($node->node_name || $node->id || '') : $node->id || '' } @descs).
")\nWill do an arbitrary balanced split");
my @working = @descs;
# create an even set of artifical nodes on which to later hang the descs
Expand Down Expand Up @@ -971,7 +971,6 @@ sub reroot {

$tmp_node = undef;
$new_root->branch_length(undef);
$new_root->remove_tag('B');

$old_root = undef;
$self->set_root_node($new_root);
Expand Down Expand Up @@ -1054,7 +1053,7 @@ sub findnode_by_id {
sub move_id_to_bootstrap{
my ($tree) = shift;
for my $node ( grep { ! $_->is_Leaf } $tree->get_nodes ) {
$node->bootstrap($node->id);
$node->bootstrap($node->id || '');
$node->id('');
}
}
Expand Down
139 changes: 79 additions & 60 deletions Bio/TreeIO.pm
View file
Expand Up @@ -90,8 +90,6 @@ use Bio::TreeIO::TreeEventBuilder;

use base qw(Bio::Root::Root Bio::Root::IO Bio::Event::EventGeneratorI Bio::Factory::TreeFactoryI);

use constant INTERNAL_NODE_ID => 'id'; # id or bootstrap, default is 'id'

=head2 new
Title : new
Expand All @@ -107,35 +105,33 @@ use constant INTERNAL_NODE_ID => 'id'; # id or bootstrap, default is 'id'
svggraph SVG graphical representation of tree
tabtree ASCII text representation of tree
lintree lintree output format
-internal_node_id : what is stored in the internal node ids,
bootstrap values or ids, coded as
'bootstrap' or 'id'
=cut

sub new {
my($caller,@args) = @_;
my $class = ref($caller) || $caller;

# or do we want to call SUPER on an object if $caller is an
# object?
if( $class =~ /Bio::TreeIO::(\S+)/ ) {
my ($self) = $class->SUPER::new(@args);
$self->_initialize(@args);
return $self;
} else {
# object?n

my $obj;
if( $class =~ /Bio::TreeIO::(\S+)/ ) {
$obj = $class->SUPER::new(@args);
$obj->_initialize(@args);
} else {
my %param = @args;
@param{ map { lc $_ } keys %param } = values %param; # lowercase keys
my $format = $param{'-format'} ||
$class->_guess_format( $param{'-file'} || $ARGV[0] ) ||
'newick';
$class->_guess_format( $param{'-file'} || $ARGV[0] ) ||
'newick';
$format = "\L$format"; # normalize capitalization to lower case

# normalize capitalization
return unless( $class->_load_format_module($format) );
return "Bio::TreeIO::$format"->new(@args);
}
return undef unless( $class->_load_format_module($format) );
$obj = "Bio::TreeIO::$format"->new(@args);
}
return $obj;
}


Expand Down Expand Up @@ -210,16 +206,18 @@ sub _eventHandler{
sub _initialize {
my($self, @args) = @_;
$self->{'_handler'} = undef;
my $internal_node_id;
$self->{'internal_node_id'} = INTERNAL_NODE_ID;
($self->{'newline_each_node'},$internal_node_id) = $self->_rearrange

$self->get_params; # Initialize the default parameters.

my ($nen,$ini) = $self->_rearrange
([qw(NEWLINE_EACH_NODE INTERNAL_NODE_ID)],@args);

# initialize the IO part
$self->_initialize_io(@args);
$self->set_param('newline_each_node',$nen);
$self->set_param('internal_node_id',$ini);

$self->attach_EventHandler(Bio::TreeIO::TreeEventBuilder->new
(-verbose => $self->verbose(), @args));
$self->internal_node_id($internal_node_id) if defined $internal_node_id;
$self->_initialize_io(@args);
#$self->debug_params;
}

=head2 _load_format_module
Expand All @@ -241,6 +239,7 @@ sub _load_format_module {
eval {
$ok = $self->_load_module($module);
};

if ( $@ ) {
print STDERR <<END;
$self: $format cannot be found
Expand All @@ -253,53 +252,73 @@ END
return $ok;
}

=head2 newline_each_node
sub param {
my $self = shift;
my $param = shift;
my $value = shift;

Title : newline_each_node
Usage : $obj->newline_each_node($newval)
Function: Get/set newline each node flag which is only applicable
for writing tree formats for nhx and newick, will
print a newline after each node or paren
Returns : value of newline_each_node (boolean)
Args : on set, new value (a boolean or undef, optional)
if (defined $value) {
$self->get_params->{$param} = $value;
}
return $self->get_params->{$param};
}

sub set_param {
my $self = shift;
my $param = shift;
my $value = shift;

=cut
#print STDERR "[$param] -> [undef]\n" if (!defined $value);
return unless (defined $value);
#print STDERR "[$param] -> [$value]\n";

sub newline_each_node{
my $self = shift;
return $self->{'newline_each_node'} = shift if @_;
return $self->{'newline_each_node'};
$self->get_params->{$param} = $value;
return $self->param($param);
}

=head2 internal_node_id
sub params {
my $self = shift;
return $self->get_params;
}
sub get_params {
my $self = shift;

Title : internal_node_id
Usage : $obj->internal_node_id($newval)
Function: Internal Node Id type, coded as 'bootstrap' or 'id'
Default is 'id'
Returns : value of internal_node_id (a scalar)
Args : on set, new value (a scalar or undef, optional)
if (!defined $self->{_params}) {
$self->{_params} = $self->get_default_params;
}

return $self->{_params};
}

=cut
sub set_params {
my $self = shift;
my $params = shift;

sub internal_node_id{
my $self = shift;
my $val = shift;
if( defined $val ) {
if( $val =~ /^b/i ) {
$val = 'bootstrap';
} elsif( $val =~ /^i/ ) {
$val = 'id';
} else {
$self->warn("Unknown value $val for internal_node_id not resetting value\n");
}
return $self->{'internal_node_id'} = $val;
}
return $self->{'internal_node_id'};
# Apply all the passed parameters to our internal parm hashref.
my $cur_params = $self->get_params;
$self->{_params} = { %$cur_params, %$params };

return $self->get_params;
}

sub get_default_params {
my $self = shift;

return {};
}

sub debug_params {
my $self = shift;

my $params = $self->get_params;

print STDERR "{\n";
foreach my $param (keys %$params) {
my $value = $params->{$param};
print STDERR " [$param] -> [$value]\n";
}
print STDERR "}\n";
}

=head2 _guess_format
Expand Down

0 comments on commit 1e21af8

Please sign in to comment.