1###################################################### 2# Tree.pm 3###################################################### 4# Author: Weigang Qiu, Chengzhi Liang, Peter Yang, Thomas Hladish 5# $Id: Tree.pm,v 1.62 2007/09/21 23:09:09 rvos Exp $ 6 7#################### START POD DOCUMENTATION ################## 8 9=head1 NAME 10 11Bio::NEXUS::Tree - Provides functions for manipulating trees 12 13=head1 SYNOPSIS 14 15new Bio::NEXUS::Tree; 16 17=head1 DESCRIPTION 18 19Provides a few useful functions for trees. 20 21=head1 FEEDBACK 22 23All feedback (bugs, feature enhancements, etc.) are all greatly appreciated. There are no mailing lists at this time for the Bio::NEXUS::Tree module, so send all relevant contributions to Dr. Weigang Qiu (weigang@genectr.hunter.cuny.edu). 24 25=head1 AUTHORS 26 27 Eugene Melamud (melamud@carb.nist.gov) 28 Thomas Hladish (tjhladish at yahoo) 29 Weigang Qiu (weigang@genectr.hunter.cuny.edu) 30 Chengzhi Liang (liangc@umbi.umd.edu) 31 Peter Yang (pyang@rice.edu) 32 33=head1 METHODS 34 35=cut 36 37package Bio::NEXUS::Tree; 38 39use strict; 40use Bio::NEXUS::Functions; 41use Bio::NEXUS::Node; 42#use Data::Dumper; # XXX this is not used, might as well not import it! 43#use Carp; 44use Bio::NEXUS::Util::Exceptions; 45use Bio::NEXUS::Util::Logger; 46use vars qw($VERSION $AUTOLOAD); 47use Bio::NEXUS; $VERSION = $Bio::NEXUS::VERSION; 48 49my $logger = Bio::NEXUS::Util::Logger->new(); 50 51=head2 new 52 53 Title : new 54 Usage : $tree = new Bio::NEXUS::Tree(); 55 Function: Creates a new Bio::NEXUS::Tree object 56 Returns : Bio::NEXUS::Tree object 57 Args : none 58 59=cut 60 61sub new { 62 my ($class) = @_; 63 my $root_node = new Bio::NEXUS::Node; 64 my $self = { name => undef, root_node => $root_node }; 65 bless $self, $class; 66 return $self; 67} 68 69=head2 clone 70 71 Name : clone 72 Usage : my $new_tree = $self->clone(); 73 Function: clone a Bio::NEXUS::Tree (self) object. All the nodes are also cloned. 74 Returns : new Bio::NEXUS::Tree object 75 Args : none 76 77=cut 78 79sub clone { 80 my ($self) = @_; 81 my $class = ref($self); 82 my $newtree = bless( { %{$self} }, $class ); 83 84 # clone nodes 85 $newtree->set_rootnode( $self->get_rootnode()->clone() ); 86 return $newtree; 87} 88 89=head2 set_rootnode 90 91 Title : set_rootnode 92 Usage : $tree->set_rootnode($newnode); 93 Function: Sets the root node to a new node 94 Returns : none 95 Args : root node (Bio::NEXUS::Node object) 96 97=cut 98 99sub set_rootnode { 100 my $self = shift; 101 my $newroot = shift; 102 $self->{root_node} = $newroot; 103} 104 105=head2 get_rootnode 106 107 Title : get_rootnode 108 Usage : $node = $tree->get_rootnode(); 109 Function: Returns the tree root node 110 Returns : root node (Bio::NEXUS::Node object) 111 Args : none 112 113=cut 114 115sub get_rootnode { 116 my $self = shift; 117 if ( defined $self->{'root_node'} ) { 118 return $self->{'root_node'}; 119 } 120} 121 122=begin comment 123 124 Title : _parse_newick 125 Usage : $tree->_parse_newick($tree_string); 126 Function: Creates a tree out of the existing tree string 127 Returns : none 128 Args : array ref of NEXUS 'words' (a newick tree string that has been parsed by &_parse_nexus_words) 129 130=end comment 131 132=cut 133 134sub _parse_newick { 135 my ( $self, $tree_words ) = @_; 136 137 my $root = $self->get_rootnode(); 138 $root->_parse_newick($tree_words); 139 $self->set_depth(); 140 $self->determine_cladogram(); 141 return; 142} 143 144=head2 set_name 145 146 Title : set_name 147 Usage : $tree->set_name($name); 148 Function: Sets the tree name 149 Returns : none 150 Args : name (string) 151 152=cut 153 154sub set_name { 155 my ( $self, $name ) = @_; 156 $self->{'name'} = $name; 157} 158 159=head2 get_name 160 161 Title : get_name 162 Usage : $name = $tree->get_name(); 163 Function: Returns the tree's name 164 Returns : name (string) or undef if name doesn't exist 165 Args : none 166 167=cut 168 169sub get_name { 170 if ( defined $_[0]->{'name'} ) { 171 return $_[0]->{'name'}; 172 } 173 else { 174 return undef; 175 } 176} 177 178=head2 set_as_default 179 180 Title : set_as_default 181 Usage : $tree->set_as_default(); 182 Function: assigns is_default variable for this object to 1. (default : 0) 183 Returns : none 184 Args : none 185 186=cut 187 188sub set_as_default { 189 my $self = shift; 190 $self->{'is_default'} = 1; 191} 192 193=head2 is_default 194 195 Title : is_default 196 Usage : $is_default_tree = $tree->is_default(); 197 Function: check whether the tree is assigned as the default. 198 Returns : 0 (false) or 1 (true) 199 Args : none 200 201=cut 202 203sub is_default { 204 my $self = shift; 205 return $self->{'is_default'}; 206} 207 208=head2 set_as_unrooted 209 210 Title : set_as_unrooted 211 Usage : $tree->set_as_unrooted(); 212 Function: assigns is_unrooted variable for this object to 1. (default : 0) 213 Returns : none 214 Args : none 215 216=cut 217 218sub set_as_unrooted { 219 my $self = shift; 220 $self->{'is_unrooted'} = 1; 221} 222 223=head2 is_rooted 224 225 Title : is_rooted 226 Usage : $is_rooted_tree = $tree->is_rooted(); 227 Function: Check whether the tree is rooted. 228 Returns : 0 (false) or 1 (true) 229 Args : none 230 231=cut 232 233sub is_rooted { 234 my $self = shift; 235 return !$self->{'is_unrooted'}; 236} 237 238=head2 determine_cladogram 239 240 Title : determine_cladogram 241 Usage : $tree->determine_cladogram(); 242 Function: Determine if a tree is a cladogram or not (that is, whether branch lengths are present) 243 Returns : none 244 Args : none 245 246=cut 247 248sub determine_cladogram { 249 my $self = shift; 250 my $root = $self->get_rootnode(); 251 if ( $root->find_lengths() ) { 252 $self->{'is_cladogram'} = 0; 253 } 254 else { 255 $self->{'is_cladogram'} = 1; 256 } 257} 258 259=head2 set_output_format 260 261 Title : set_output_format 262 Usage : $tree->set_output_format('STD'); 263 Function: Sets the output format for the Tree, (options : STD or NHX) 264 Returns : none 265 Args : string: 'STD' or 'NHX' 266 267=cut 268 269sub set_output_format { 270 my ( $self, $format ) = @_; 271 $self->{'_out_format'} = $format; 272} 273 274=head2 get_output_format 275 276 Title : get_output_format 277 Usage : $output_format = $tree->get_output_format(); 278 Function: Returns the output format for the Tree, (options : STD or NHX) 279 Returns : string: 'STD' or 'NHX' 280 Args : none 281 282=cut 283 284sub get_output_format { 285 my ($self) = @_; 286 if ( defined $self->{_out_format} ) { 287 return $self->{_out_format}; 288 } 289 else { 290 my $format = 'STD'; 291 my $nodes = $self->get_nodes(); 292 my @otus; 293 for my $node ( @{$nodes} ) { 294 if ( $node->{is_nhx} ) { 295 $format = 'NHX'; 296 last; 297 } 298 } 299 $self->{_out_format} = $format; 300 } 301 return $self->{_out_format}; 302} 303 304=head2 is_cladogram 305 306 Title : is_cladogram 307 Usage : &dothis() if $tree->is_cladogram(); 308 Function: Returns whether tree is a cladogram or not 309 Returns : 0 (no) or 1 (yes) 310 Args : none 311 312=cut 313 314sub is_cladogram { 315 my $self = shift; 316 return $self->{'is_cladogram'}; 317} 318 319=head2 as_string 320 321 Title : as_string 322 Usage : $treestring = $tree->as_string(); 323 Function: Returns the tree as a string 324 Returns : tree string (string) 325 Args : none 326 327=cut 328 329sub as_string { 330 my $self = shift; 331 my $root = $self->get_rootnode(); 332 my $string; 333 $root->to_string( \$string, 0, $self->get_output_format ); 334 $string =~ s/\,$/\;/; 335 return $string; 336} 337 338=head2 as_string_inodes_nameless 339 340 Title : as_string_inodes_nameless 341 Usage : $treestring = $tree->as_string_inodes_nameless(); 342 Function: Returns the tree as a string without internal node names 343 Returns : tree string (string) 344 Args : none 345 346=cut 347 348sub as_string_inodes_nameless { 349 my $self = shift; 350 my $root = $self->get_rootnode(); 351 my $string; 352 $root->to_string( \$string, 1, $self->get_output_format ); 353 $string =~ s/\,$/\;/; 354 return $string; 355} 356 357=head2 get_nodes 358 359 Title : get_nodes 360 Usage : @nodes = @{$tree->get_nodes()}; 361 Function: Returns the list of ALL nodes in the tree 362 Returns : reference to array of nodes (Bio::NEXUS::Node objects) 363 Args : none 364 365=cut 366 367sub get_nodes { 368 my $self = shift; 369 my $root = $self->get_rootnode(); 370 my @nodes; 371 my $i = 1; 372 $root->walk( \@nodes, \$i ); 373 $root->set_name('root') 374 if !$root->get_name() || $root->get_name() =~ /^inode1/; 375 return \@nodes; 376} 377 378=head2 get_node_names 379 380 Title : get_node_names 381 Usage : @otu_names = @{$tree->get_node_names()}; 382 Function: Returns the list of names of otus (terminal nodes) 383 Returns : array ref of node names 384 Args : none 385 386=cut 387 388sub get_node_names { 389 my $self = shift; 390 my $nodes = $self->get_nodes(); 391 my @otus; 392 for my $node ( @{$nodes} ) { 393 if ( $node->is_otu() ) { 394 push @otus, $node->get_name(); 395 } 396 } 397 return \@otus; 398} 399 400=head2 get_distances 401 402 Title : get_distances 403 Usage : %distances = %{$tree->get_distances()}; 404 Function: Finds the distances from the root node for all OTUs 405 Returns : reference to a hash of OTU names as keys and distances as values 406 Args : none 407 408=cut 409 410sub get_distances { 411 my $self = shift; 412 my $nodes = $self->get_nodes(); 413 my $root = $self->get_rootnode(); 414 my %distances; 415 for my $node ( @{$nodes} ) { 416 $distances{ $node->get_name() } = $root->get_distance($node); 417 } 418 return \%distances; 419} 420 421=head2 get_tree_length 422 423 Title : get_tree_length 424 Usage : $tre_length = $self->get_tree_length; 425 Function: Gets the total branch lengths in the tree. 426 Returns : total branch length 427 Args : none 428 429=cut 430 431sub get_tree_length { 432 my $self = shift; 433 my $root = $self->get_rootnode(); 434 return $root->get_total_length(); 435} 436 437=head2 get_support_values 438 439 Title : get_support_values 440 Usage : %bootstraps = %{$tree->get_support_values()}; 441 Function: Finds all branch support values for all OTUs 442 Returns : reference to a hash where OTU names are keys and branch support values are values 443 Args : none 444 445=cut 446 447sub get_support_values { 448 my $self = shift; 449 my $nodes = $self->get_nodes(); 450 my %bootstraps; 451 for my $node ( @{$nodes} ) { 452 my $boot = $node->get_support_value(); 453 $bootstraps{ $node->get_name() } = $boot if $boot; 454 } 455 return \%bootstraps; 456} 457 458=begin comment 459 460 Title : _set_xcoord 461 Usage : $tree->_set_xcoord($xpos,$maxx); 462 Function: Determines x coords of OTUs and internal nodes 463 Returns : none 464 Args : maximum x (number) 465 466=end comment 467 468=cut 469 470sub _set_xcoord { 471 my ( $self, $maxx, $cladogramMethod ) = @_; 472 my $xcoord = 473 [ { 'node' => '', 'xcoord' => '' }, { 'node' => '', 'xcoord' => '' } ]; 474 my $root = $self->get_rootnode(); 475 my @nodes = @{ $self->get_nodes() }; 476 if ( $self->is_cladogram() || $cladogramMethod ) { 477 $cladogramMethod = 'normal' unless $cladogramMethod; 478 my $maxdepth = $self->max_depth(); 479 my $unit = $maxx / $maxdepth; 480 my @xcoord; 481 if ( $cladogramMethod eq "accelerated" ) { 482 for my $node (@nodes) { 483 if ( $node->is_otu() ) { 484 $node->_set_xcoord( $maxdepth * $unit ); 485 } 486 else { 487 $node->_set_xcoord( $node->get_depth() * $unit ); 488 } 489 } 490 } 491 elsif ( $cladogramMethod eq "normal" ) { 492 my %depth = %{ $self->get_depth() }; 493 for my $node (@nodes) { 494 $node->_set_xcoord( $node->get_depth() * $unit ); 495 } 496 } 497 } 498 else { 499 for my $node (@nodes) { 500 $node->_set_xcoord( $root->get_distance($node) ); 501 } 502 } 503} 504 505=begin comment 506 507 Title : _set_ycoord 508 Usage : $tree->_set_ycoord($ypos,$spacing); 509 Function: Determines y coords of OTUs and internal nodes 510 Returns : none 511 Args : initial y position (number), space between OTUs (number) 512 513=end comment 514 515=cut 516 517sub _set_ycoord { 518 my ( $self, $ypos, $spacing ) = @_; 519 my $root = $self->get_rootnode(); 520 $root->_assign_otu_ycoord( \$ypos, \$spacing ); 521 $root->_assign_inode_ycoord(); 522} 523 524=head2 set_depth 525 526 Title : set_depth 527 Usage : $tree->set_depth(); 528 Function: Sets depth of root node 529 Returns : none 530 Args : none 531 532=cut 533 534sub set_depth { 535 my $self = shift; 536 my $root = $self->get_rootnode(); 537 $root->set_depth(0); 538} 539 540=head2 get_depth 541 542 Title : get_depth 543 Usage : %depth=%{$tree->get_depth()}; 544 Function: Get depth in tree of all OTUs and internal nodes 545 Returns : reference to hash with keys = node names and values = depth 546 Args : none 547 548=cut 549 550sub get_depth { 551 my $self = shift; 552 my $nodes = $self->get_nodes(); 553 my %depth; 554 for my $node ( @{$nodes} ) { 555 my $d = $node->get_depth(); 556 $depth{ $node->get_name() } = $d if ( $d || ( $d == 0 ) ); 557 } 558 return \%depth; 559} 560 561=head2 max_depth 562 563 Title : max_depth 564 Usage : $maxdepth=%{$tree->max_depth()}; 565 Function: Get maximum depth of tree 566 Returns : integer indicating maximum depth 567 Args : none 568 569=cut 570 571sub max_depth { 572 my $self = shift; 573 my %depth = %{ $self->get_depth() }; 574 my @sorted = sort { $a <=> $b } values %depth; 575 return ( pop @sorted ); 576} 577 578=head2 find 579 580 Title : find 581 Usage : $node = $tree->find($name); 582 Function: Finds the first occurrence of a node called 'name' in the tree 583 Returns : Bio::NEXUS::Node object 584 Args : name (string) 585 586=cut 587 588sub find { 589 my ( $self, $name ) = @_; 590 my $rootnode = $self->get_rootnode(); 591 my $node = $rootnode->find($name); 592 return $node; 593} 594 595=head2 find_all 596 597 Title : find_all 598 Usage : @nodes = @{ $tree->find_all($name) }; 599 Function: find all occurrences of nodes called 'name' in the tree 600 Returns : Bio::NEXUS::Node objects 601 Args : name (string) 602 603=cut 604 605sub find_all { 606 my $self = shift; 607 my @nodes; 608 my @all_nodes = @{ $self->get_nodes() }; 609 my $name = shift; 610 for my $node (@all_nodes) { 611 if ( $name eq $node->get_name() ) { 612 push( @nodes, $node ); 613 } 614 } 615 return \@nodes; 616} 617 618=head2 prune 619 620 Name : prune 621 Usage : $tree->prune($OTUlist); 622 Function: Removes everything from the tree except for OTUs specified in $OTUlist 623 Returns : none 624 Args : list of OTUs (string) 625 626=cut 627 628sub prune { 629 my ( $self, $OTUlist ) = @_; 630 $OTUlist = ' ' . $OTUlist . ' '; 631 my $rootnode = $self->get_rootnode(); 632 $rootnode->prune($OTUlist); 633} 634 635=head2 equals 636 637 Name : equals 638 Usage : $tree->equals($another_tree); 639 Function: compare if two trees are equivalent in topology 640 Returns : 1 if equal or 0 if not 641 Args : another Bio::NEXUS::Tree object 642 643=cut 644 645sub equals { 646 my ( $self, $tree ) = @_; 647 648 if ( $self->get_name() ne $tree->get_name() ) { return 0; } 649 return $self->get_rootnode()->equals( $tree->get_rootnode() ); 650} 651 652sub _equals_test { 653 my ( $self, $tree ) = @_; 654 655 if ( $self->get_name() ne $tree->get_name() ) { return 0; } 656 return $self->get_rootnode()->_equals_test( $tree->get_rootnode() ); 657} 658 659=head2 reroot 660 661 Name : reroot 662 Usage : $tree = $tree->reroot($outgroup_name); 663 Function: re-root a tree with a node as outgroup 664 Returns : 665 Args : the node name to be used as new outgroup 666 667=cut 668 669sub reroot { 670 my ( $self, $outgroup_name, $dist_back_to_newroot ) = @_; 671 if ( not defined $outgroup_name ) { 672 Bio::NEXUS::Util::Exceptions::BadArgs->throw( 673 'error' => 'An outgroup name must be supplied as an argument in order to reroot' 674 ); 675 } 676 677 my $tree = $self->clone(); 678 679 # find the current root of the tree 680 my $oldroot = $tree->get_rootnode(); 681 682 # rename it, since nexplot relies on all nodes having unique names 683 &_rename_oldroot( $tree, $oldroot ); 684 685 # get the outgroup node 686 my $outgroup = $tree->find($outgroup_name); 687 688 # create & name a new node that will become the new root 689 my $newroot = new Bio::NEXUS::Node(); 690 691 if ( $dist_back_to_newroot 692 && $dist_back_to_newroot == $outgroup->get_length() ) 693 { 694 $newroot = $outgroup->get_parent(); 695 $outgroup->set_length($dist_back_to_newroot); 696 $newroot->get_parent()->_rearrange($newroot); 697 } 698 else { 699 700 # find the node that will (temporarily) become the newroot's parent 701 my $outgroup_old_parent = $outgroup->get_parent(); 702 703 # get the siblings of the outgroup 704 my $newroot_siblings = $outgroup->get_siblings(); 705 706 # get the correct branch lengths for newroot and outgroup 707 &_position_newroot( $outgroup, $newroot, $dist_back_to_newroot ); 708 709 # make outgroup the newroot's child and newroot the outgroup's parent 710 $newroot->adopt( $outgroup, 1 ); 711 712 # remove the outgroup from the old parent's children 713 $outgroup_old_parent->set_children($newroot_siblings); 714 715 # add the newroot as a child 716 $outgroup_old_parent->adopt( $newroot, 0 ); 717 718# recursively reverse the parent-child relationships between newroot and oldroot 719 $outgroup_old_parent->_rearrange($newroot); 720 } 721 722 # set newroot's values to make it root 723 $newroot->set_name('root'); 724 $newroot->set_parent_node(); 725 $newroot->set_support_value(); 726 $newroot->set_length(); 727 $newroot->set_depth(0); 728 $tree->set_rootnode($newroot); 729 730 # remove oldroot if the tree was bifurcating 731 &_remove_oldroot_if_superfluous($oldroot); 732 733 return $tree; 734} 735 736sub _rename_oldroot { 737 my ( $tree, $oldroot ) = @_; 738 my $i = 0; 739 my $renamed_oldroot = 0; 740 my $oldroot_name = 'oldroot'; 741 while ( $renamed_oldroot == 0 ) { 742 if ( !$tree->find("$oldroot_name") ) { 743 $oldroot->set_name("$oldroot_name"); 744 $renamed_oldroot = 1; 745 } 746 else { 747 $oldroot_name = "oldroot" . "$i"; 748 $i++; 749 } 750 } 751} 752 753sub _position_newroot { 754 my ( $outgroup, $newroot, $dist_back_to_newroot ) = @_; 755 if ( $outgroup->get_length() ) { 756 my $outgroup_length = $outgroup->get_length(); 757 if ($dist_back_to_newroot) { 758 if ( $dist_back_to_newroot < $outgroup_length 759 && $dist_back_to_newroot > 0 ) 760 { 761 ## $dist_back_to_newroot should already be negative 762 $newroot->set_length( 763 $outgroup_length - $dist_back_to_newroot ); 764 $outgroup->set_length($dist_back_to_newroot); 765 } 766 else { 767 Bio::NEXUS::Util::Exceptions::BadNumber->throw( 768 'error' => "Branch length error: The new root's position\n" 769 . "up the tree from the outgroup must be a positive\n" 770 . "number less than or equal to the outgroup's branch length.\n" 771 ); 772 } 773 } 774 else { 775 $newroot->set_length( $outgroup_length / 2 ); 776 $outgroup->set_length( $outgroup_length / 2 ); 777 } 778 } 779 else { 780 if ($dist_back_to_newroot) { 781 Bio::NEXUS::Util::Exceptions::BadArgs->throw( 782 'error' => "You provided a position for the new root on the\n" 783 . "outgroup's branch length, but the outgroup does\n" 784 . "not have a branch length.\n" 785 ); 786 } 787 } 788} 789 790sub _remove_oldroot_if_superfluous { 791 my ($oldroot) = @_; 792 if ( @{ $oldroot->get_children() } == 1 ) { 793 my $oldroot_child = ${ $oldroot->get_children() }[0]; 794 if ( defined $oldroot->get_length() 795 || defined $oldroot_child->get_length() ) 796 { 797 $oldroot_child->set_length( 798 $oldroot->get_length() + $oldroot_child->get_length() ); 799 } 800 my $oldroot_parent = $oldroot->get_parent(); 801 $oldroot_parent->set_children( $oldroot->get_siblings() ); 802 $oldroot_parent->adopt( $oldroot_child, 0 ); 803 } 804} 805 806=head2 select_subtree 807 808 Name : select_subtree 809 Usage : $new_tree_obj = $self->select_subtree($node_name); 810 Function: selects the subtree (the given node and all its children) from the tree object. 811 Returns : new Bio::NEXUS::Tree object 812 Args : Node name 813 814=cut 815 816sub select_subtree { 817 my ( $self, $nodename ) = @_; 818 my $newroot = $self->find($nodename); 819 my $treename = $self->get_name(); 820 if ( not $newroot ) { 821 Bio::NEXUS::Util::Exceptions::BadArgs->throw( 822 'error' => "Node $nodename not found in $treename" 823 ); 824 } 825 $newroot = $newroot->clone(); # need to clone subtree 826 $newroot->set_parent_node(); # make it as root 827 $newroot->set_support_value(); 828 $newroot->set_length(); 829 my $tree = new Bio::NEXUS::Tree(); 830 $tree->set_name( $self->get_name() ); 831 $tree->set_rootnode($newroot); 832 return $tree; 833} 834 835=head2 exclude_subtree 836 837 Name : exclude_subtree 838 Usage : $new_tree_obj = $self->exclude_subtree($node_name); 839 Function: removes the given node and all its children from the tree object. 840 Returns : new Bio::NEXUS::Tree object 841 Args : Node name 842 843=cut 844 845sub exclude_subtree { 846 my ( $self, $nodename ) = @_; 847 my $treename = $self->get_name(); 848 my $tree = $self->clone(); 849 my $removenode = $tree->find($nodename); 850 851 if ( not $removenode ) { 852 Bio::NEXUS::Util::Exceptions::BadArgs->throw( 853 'error' => "Node $nodename not found in $treename" 854 ); 855 } 856 857 my $parent = $removenode->get_parent(); 858 my @children = @{ $parent->get_children() }; 859 $parent->set_children(); 860 for my $child (@children) { 861 if ( $child->get_name() ne $removenode->get_name() ) { 862 $parent->add_child($child); 863 } 864 } 865 if ( @{ $parent->get_children() } == 1 ) { 866 my $sibling = $parent->get_children()->[0]; 867 $parent->combine($sibling); 868 } 869 870 return $tree; 871} 872 873=head2 get_mrca_of_otus 874 875 Name : get_mrca_of_otus 876 Usage : $node = $self->get_mrca_of_otus($otus); 877 Function: gets the most recent common ancestor for the input $otus 878 Returns : Bio::NEXUS::Node object 879 Args : $otus : Array reference of the OTUs 880 881=cut 882 883sub get_mrca_of_otus { 884 my ( $self, $otus) = @_; 885 my $root_node = $self->get_rootnode; 886 return $root_node->get_mrca_of_otus($otus); 887} 888 889sub AUTOLOAD { 890 return if $AUTOLOAD =~ /DESTROY$/; 891 my $package_name = __PACKAGE__ . '::'; 892 893 # The following methods are deprecated and are temporarily supported 894 # via a warning and a redirection 895 my %synonym_for = ( 896 "${package_name}node_list" => "${package_name}get_nodes", 897 "${package_name}otu_list" => "${package_name}get_node_names", 898 "${package_name}set_xcoord" => "${package_name}_set_xcoord", 899 "${package_name}set_ycoord" => "${package_name}_set_ycoord", 900 "${package_name}name" => "${package_name}get_name", 901 "${package_name}set_tree" => "${package_name}_parse_newick", 902 ); 903 904 if ( defined $synonym_for{$AUTOLOAD} ) { 905 $logger->warn("$AUTOLOAD() is deprecated; use $synonym_for{$AUTOLOAD}() instead"); 906 goto &{ $synonym_for{$AUTOLOAD} }; 907 } 908 else { 909 Bio::NEXUS::Util::Exceptions::UnknownMethod->throw( 910 'error' => "ERROR: Unknown method $AUTOLOAD called" 911 ); 912 } 913 return; 914} 915 9161; 917