444
436
$lineage_tree = $self->new(-node => $thing);
445
437
$lineage_leaf = $thing;
448
# get the lca of this node and every leaf of the main tree until we find
449
# the branch that isn't in the main tree yet
450
my ($main_tree_lca, $new_branch_base);
451
foreach my $leaf ($self->get_leaf_nodes) {
452
$main_tree_lca = $self->get_lca($lineage_leaf, $leaf) || ($self->warn("couldn't get the lca of nodes ".$lineage_leaf->id." and ".$leaf->id."!") && next);
454
my $branch_lca = $lineage_tree->find_node(-internal_id => $main_tree_lca->internal_id);
455
($new_branch_base) = $branch_lca->each_Descendent;
456
if ($new_branch_base) {
457
if ($self->find_node(-internal_id => $new_branch_base->internal_id)) {
458
# this branch is already in the main tree, try again
459
$new_branch_base = undef;
467
# the lca is the lineage leaf itself, nothing for us to merge
440
# see if any node in the supplied lineage is in our tree - that will be
441
# our lca and we can merge at the node below
442
my @lineage = ($lineage_leaf, reverse($self->get_lineage_nodes($lineage_leaf)));
444
for my $i (0..$#lineage) {
445
my $lca = $self->find_node(-internal_id => $lineage[$i]->internal_id) || next;
448
# the supplied thing to merge is already in the tree, nothing to do
451
# $i is the lca, so the previous node is new to the tree and should
453
$lca->add_Descendent($lineage[$i-1]);
471
$new_branch_base || ($self->warn("couldn't merge the lineage of ".$lineage_leaf->id." with the rest of the tree!\n") && return);
472
$main_tree_lca->add_Descendent($new_branch_base);
457
$merged || ($self->warn("Couldn't merge the lineage of ".$lineage_leaf->id." with the rest of the tree!\n") && return);
475
460
=head2 contract_linear_paths
510
505
$self->splice(@remove) if @remove;
507
my $root = $self->get_root_node;
508
my @descs = $root->each_Descendent;
510
my $new_root = shift(@descs);
511
$self->set_root_node($new_root);
512
$new_root->ancestor(undef);
519
Example : is_binary(); is_binary($node);
520
Description: Finds if the tree or subtree defined by
521
the internal node is a true binary tree
525
Args : Internal node Bio::Tree::NodeI, optional
534
my $node = shift || $self->get_root_node;
537
my @descs = $node->each_Descendent;
538
$binary = 0 unless @descs == 2 or @descs == 0;
539
#print "$binary, ", scalar @descs, "\n";
542
foreach my $desc (@descs) {
543
$binary += $self->is_binary($desc) -1;
545
$binary = 0 if $binary < 0;
553
Usage : force_binary()
554
Function: Forces the tree into a binary tree, splitting branches arbitrarily
555
and creating extra nodes as necessary, such that all nodes have
556
exactly two or zero descendants.
560
For example, if we are the tree $tree:
576
(A has 6 descendants B-G)
578
After calling $tree->force_binary(), $tree looks like:
608
(Where X are artificially created nodes with ids 'artificial_n', where n is
609
an integer making the id unique within the tree)
615
my $node = shift || $self->get_root_node;
617
my @descs = $node->each_Descendent;
619
$self->warn("Node ".($node->can('node_name') ? ($node->node_name || $node->id) : $node->id).
620
" has more than two descendants\n(".
621
join(", ", map { $node->can('node_name') ? ($node->node_name || $node->id) : $node->id } @descs).
622
")\nWill do an arbitrary balanced split");
623
my @working = @descs;
624
# create an even set of artifical nodes on which to later hang the descs
625
my $half = @working / 2;
626
$half++ if $half > int($half);
631
foreach my $top_node (@artificials || $node) {
633
my $art = $top_node->new(-id => "artificial_".++$self->{_art_num});
634
$top_node->add_Descendent($art);
635
push(@this_level, $art);
638
@artificials = @this_level;
641
# attach two descs to each artifical leaf
642
foreach my $art (@artificials) {
644
my $desc = shift(@working) || $node->new(-id => "artificial_".++$self->{_art_num});
645
$desc->ancestor($art);
649
elsif (@descs == 1) {
650
# ensure that all nodes have 2 descs
651
$node->add_Descendent($node->new(-id => "artificial_".++$self->{_art_num}));
654
foreach my $desc (@descs) {
655
$self->force_binary($desc);
659
=head2 simplify_to_leaves_string
661
Title : simplify_to_leaves_string
662
Usage : my $leaves_string = $tree->simplify_to_leaves_string()
663
Function: Creates a simple textual representation of the relationship between
664
leaves in self. It forces the tree to be binary, so the result may
665
not strictly correspond to the tree (if the tree wasn't binary), but
666
will be as close as possible. The tree object is not altered. Only
667
leaf node ids are output, in a newick-like format.
673
sub simplify_to_leaves_string {
676
# Before contracting and forcing binary we need to clone self, but Clone.pm
677
# clone() seg faults and fails to make the clone, whilst Storable dclone
678
# needs $self->{_root_cleanup_methods} deleted (code ref) and seg faults at
679
# end of script. Let's make our own clone...
680
my $tree = $self->_clone;
682
$tree->contract_linear_paths(1);
684
foreach my $node ($tree->get_nodes) {
686
$id = ($node->is_Leaf && $id !~ /^artificial/) ? $id : '';
691
my @data = $self->_simplify_helper($tree->get_root_node, \%paired);
693
return join(',', @data);
696
# safe tree clone that doesn't seg fault
698
my ($self, $parent, $parent_clone) = @_;
699
$parent ||= $self->get_root_node;
700
$parent_clone ||= $self->_clone_node($parent);
702
foreach my $node ($parent->each_Descendent()) {
703
my $child = $self->_clone_node($node);
704
$child->ancestor($parent_clone);
705
$self->_clone($node, $child);
707
$parent->ancestor && return;
709
my $tree = $self->new(-root => $parent_clone);
713
# safe node clone that doesn't seg fault, but deliberately loses ancestors and
716
my ($self, $node) = @_;
717
my $clone = $node->new;
719
while (my ($key, $val) = each %{$node}) {
720
if ($key eq '_desc' || $key eq '_ancestor') {
723
${$clone}{$key} = $val;
729
# tree string generator for simplify_to_leaves_string, based on
730
# Bio::TreeIO::newick::_write_tree_Helper
731
sub _simplify_helper {
732
my ($self, $node, $paired) = @_;
733
return () if (!defined $node);
736
foreach my $node ($node->each_Descendent()) {
737
push(@data, $self->_simplify_helper($node, $paired));
740
my $id = $node->id_output || '';
742
unless (exists ${$paired}{"@data"} || @data == 1) {
743
$data[0] = "(" . $data[0];
745
${$paired}{"@data"} = 1;
1009
=head2 move_id_to_bootstrap
1011
Title : move_id_to_bootstrap
1012
Usage : $tree->move_id_to_bootstrap
1013
Function: Move internal IDs to bootstrap slot
1020
sub move_id_to_bootstrap{
1022
for my $node ( grep { ! $_->is_Leaf } $tree->get_nodes ) {
1023
$node->bootstrap($node->id);
1031
Example : $key = $stat->add_traits($tree, $trait_file, 3);
1032
Description: Add traits to a Bio::Tree:Tree nodes
1033
of a tree from a file.
1034
Returns : trait name
1035
Exceptions : log an error if a node has no value in the file
1038
The trait file is a tab-delimied text file and need to have a header
1039
line giving names to traits. The first column contains the leaf node
1040
ids. Subsequent columns contain different trait value sets. Columns
1041
numbering starts from 0. The default trait column is the second
1042
(1). The returned hashref has one special key, my_trait_name, that
1043
holds the trait name. Single or double quotes are removed.
1047
sub _read_trait_file {
1050
my $column = shift || 1;
1053
open my $TRAIT, "<", $file or $self->("Can't find file $file: $!\n");
1061
$traits->{'my_trait_name'} = $line[$column];
1066
last unless $line[0];
1067
$traits->{$line[0]} = $line[$column];
1078
my $traits = $self->_read_trait_file($file, $column); # filename, trait column
1079
my $key = $traits->{'my_trait_name'};
1080
#use YAML; print Dump $traits; exit;
1081
foreach my $node ($self->get_leaf_nodes) {
1082
# strip quotes from the node id
1083
$node->id($1) if $node->id =~ /^['"]+(.*)['"]+$/;
1086
$node->add_tag_value($key, $traits->{ $node->id } );
1088
$self->throw("ERROR: No trait for node [".
1089
$node->id. "/". $node->internal_id. "]")
added
removed
Bio/Tree/TreeFunctionsI.pm
