[Bio] / FigKernelPackages / FIGtree.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/FIGtree.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1, Sat Nov 27 22:55:49 2004 UTC revision 1.3, Mon Dec 5 19:06:30 2005 UTC
# Line 1  Line 1 
1    #
2    # Copyright (c) 2003-2006 University of Chicago and Fellowship
3    # for Interpretations of Genomes. All Rights Reserved.
4    #
5    # This file is part of the SEED Toolkit.
6    #
7    # The SEED Toolkit is free software. You can redistribute
8    # it and/or modify it under the terms of the SEED Toolkit
9    # Public License.
10    #
11    # You should have received a copy of the SEED Toolkit Public License
12    # along with this program; if not write to the University of Chicago
13    # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14    # Genomes at veronika@thefig.info or download a copy from
15    # http://www.theseed.org/LICENSE.TXT.
16    #
17    
18  package FIGtree;  package FIGtree;
19    
20  # use Carp;  # use Carp;
# Line 32  Line 49 
49          FIG_nodes_within_dist          FIG_nodes_within_dist
50          FIG_num_nodes          FIG_num_nodes
51          FIG_num_tips          FIG_num_tips
52            FIG_num_bunches
53            FIG_path_length
54          FIG_path_to_first_tip          FIG_path_to_first_tip
55          FIG_path_to_node          FIG_path_to_node
56          FIG_path_to_node_ref          FIG_path_to_node_ref
# Line 43  Line 62 
62          FIG_prune_node          FIG_prune_node
63          FIG_prune_tip          FIG_prune_tip
64          FIG_random_order_tree          FIG_random_order_tree
65            FIG_region_size
66          FIG_representative_tree          FIG_representative_tree
67          FIG_reverse_tree          FIG_reverse_tree
68          FIG_shared_tips          FIG_shared_tips
69            FIG_split_tree
70          FIG_steps_to_node          FIG_steps_to_node
71          FIG_steps_to_root          FIG_steps_to_root
72          FIG_steps_to_fist_tip          FIG_steps_to_fist_tip
# Line 53  Line 74 
74          FIG_tips_of_tree          FIG_tips_of_tree
75          FIG_tips_within_dist          FIG_tips_within_dist
76          FIG_tips_within_steps          FIG_tips_within_steps
77            FIG_tree_diameter
78          FIG_tree_length          FIG_tree_length
79            FIG_tree_depth
80            FIG_tree_size
81          add_FIG_branch_attrib          add_FIG_branch_attrib
82          add_FIG_desc          add_FIG_desc
83          add_FIG_node_attrib          add_FIG_node_attrib
# Line 61  Line 85 
85          collapse_FIG_tree          collapse_FIG_tree
86          collect_all_tips          collect_all_tips
87          collect_all_nodes          collect_all_nodes
88            collect_tips_and_dist
89          delete_elm          delete_elm
90          delete_FIG_branch_attrib          delete_FIG_branch_attrib
91          delete_FIG_descRef          delete_FIG_descRef
# Line 113  Line 138 
138          most_distant_tip_path          most_distant_tip_path
139          most_distant_tip_name          most_distant_tip_name
140          most_distant_tip_ref          most_distant_tip_ref
         most_distant_tip_path  
141          normalize_FIG_tree          normalize_FIG_tree
142          nodes_down_within_dist          nodes_down_within_dist
143          nodes_up_within_dist          nodes_up_within_dist
# Line 140  Line 164 
164          set_FIG_ith_node_attrib          set_FIG_ith_node_attrib
165          set_FIG_ith_branch_attrib          set_FIG_ith_branch_attrib
166          set_FIG_undef_branch          set_FIG_undef_branch
167            sort_list_of_pairs
168          std_unrooted_FIG          std_unrooted_FIG
169          tips_down_within_steps          tips_down_within_steps
170          tips_up_within_steps          tips_up_within_steps
# Line 639  Line 664 
664  #  statistics functions -- tree operations without side effects  #  statistics functions -- tree operations without side effects
665  #------------------------------------------------------------------  #------------------------------------------------------------------
666  sub FIG_tree_length {  sub FIG_tree_length {
667    # adds up the distances of all nodes of tree
668      my ($node, $notroot) = @_;      my ($node, $notroot) = @_;
669      array_ref( $node) || return;      array_ref( $node) || return;
670      my $x = $notroot ? get_FIG_X( $node ) : 0;      my $x = $notroot ? get_FIG_X( $node ) : 0;
671      defined( $x ) || ( $x = 1 );      defined( $x ) || ( $x = 1 );
672        #print "\nat node = $node with value of x = $x";
673      my $imax = get_FIG_numDesc($node);      my $imax = get_FIG_numDesc($node);
674      for ( my $i = 1; $i <= $imax; $i++ ) {      for ( my $i = 1; $i <= $imax; $i++ ) {
675          $x += FIG_tree_length( get_FIG_ith_desc($node, $i), 1 );          $x += FIG_tree_length( get_FIG_ith_desc($node, $i), 1 );
# Line 651  Line 677 
677      $x;      $x;
678  }  }
679    
680    sub FIG_tree_diameter {
681    # locates the two most distant tips in tree and
682    # calculates distance of its path
683      my ($fig) = @_;
684      my @tpairs = sort_list_of_pairs( collect_tips_and_dist($fig) );
685      my $t1 = shift @tpairs;
686      my $x1 = shift @tpairs;
687      my $x2 = pop @tpairs;
688      my $t2 = pop @tpairs;
689      &FIG_dist_tip_to_tip($fig,$t1->[0],$t2->[0]);
690    }
691    
692    sub FIG_path_length {
693    # given a path, it calculates the distance/length of it
694    # check distance_along_path to get path length given
695    # two points rather than a path like it is here
696        my $length=0;
697        map { $length += get_FIG_X($_) } @_;
698        return $length;
699    }
700    sub FIG_tree_depth {
701    # given a tree -its root node- it calculates depth of it;
702    # or in other words, the number of internal nodes between
703    # the root and its most distant tip
704       my ($node) = @_;
705       my $path = &most_distant_tip_path($node,1);
706       return $path;
707    }
708    
709    sub FIG_tree_size {
710    # number of internal and external nodes of the tree
711    # this way: takes n^2
712    #  return (FIG_num_nodes(@_) + FIG_num_tips(@_));
713    #this other way takes n
714       my @nodes = collect_all_noderef(@_);
715       return scalar @nodes;
716    }
717    
718    sub FIG_num_bunches {
719    # a bunch is a subregion or split of the tree
720    # the right number of subregions is a heuristic
721    # in our case, we choose it based on the size of the tree
722       my ($fig) = @_;
723       my $lowN = int (log FIG_num_tips($fig));
724       my $hiN = &FIG_tree_depth($fig);
725       my $midN = 3;
726       my @array = ($lowN, $hiN, $midN);
727       sort { $a <=> $b } @array;
728       my $numBunches = pop @array;
729       while ($numBunches <= 0) { $numBunches = pop @array; }
730       return $numBunches;
731    }
732    
733    sub FIG_region_size {
734    # roughly speaking, we divide the tips evenly among the regions
735    # note, other heuristics can be implemented here
736       my ($fig, $numBunches) = @_;
737      if (! array_ref($fig)) { print "\split info missing, no tree"; return undef;}
738      if (! $numBunches) { print "\nsplit info missing, no numbunch"; return undef;}
739      if ($numBunches == 1) {print "\nnumbunch is one";return $fig; }
740    
741       my @tips = collect_all_tips($fig);
742       my $numtips = scalar @tips;
743       my $regionSize = int ($numtips / $numBunches);
744       if ($regionSize <= 0) { print "\nerror calculating size"; return undef; }
745       else { return $regionSize; }
746    }
747    
748  sub FIG_nodes_of_tree {  sub FIG_nodes_of_tree {
749  # returns list of non-tip node references  # returns list of non-tip node references
750     &collect_all_nodes( @_ );     &collect_all_nodes( @_ );
# Line 788  Line 882 
882  }  }
883    
884  sub FIG_num_tips {  sub FIG_num_tips {
885  # tot tips of tree rooted at $fig  # tot tips/leaves of tree rooted at $fig
886     ($fig)= @_;     ($fig)= @_;
887     my $tips =  &collect_all_tips($fig, []);     my @tips =  &collect_all_tips($fig);
888     return scalar @$tips;     return scalar @tips;
889  }  }
890    
891  sub FIG_num_nodes {  sub FIG_num_nodes {
892  # tot non-tip nodes of tree rooted at $fig  # tot non-tip nodes of tree rooted at $fig
893     ($fig) = @_;     ($fig) = @_;
894     my $nodes = &collect_all_nodes($fig, []);     my @nodes = collect_all_nodes($fig);
895     return scalar @$nodes;     return  scalar @nodes;
896  }  }
897    
898    
899    
900  sub FIG_first_tip {  sub FIG_first_tip {
901  #first tip along path of $node  #first tip along path of $node
902     my ($node) = @_;     my ($node) = @_;
# Line 891  Line 987 
987    
988  sub collect_all_tips {  sub collect_all_tips {
989  # collects tiprefs of subtree rooted at $node  # collects tiprefs of subtree rooted at $node
990     ($node , $tipList) = @_;     ($node , @tipList) = @_;
991     my $child;     my $child;
992     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef  }     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef  }
993     if (&is_FIG_tip( $node ) )  {  push( @$tipList, $node )}     if (&is_FIG_tip( $node ) )  {  push( @tipList, $node )}
994       else {
995           foreach $child (@{$node->[3]})
996             { &collect_all_tips($child,@tipList); }
997       }
998       return @tipList;
999    }
1000    
1001    sub collect_tips_and_dist {
1002    # collects tiprefs of subtree rooted at $node
1003    # it also calculates accum. distance from root to each tip
1004       $node = shift @_;
1005       my $dist = shift @_;
1006       @tipList = @_;
1007       my $child;
1008       my $parent;
1009       $dist = defined($dist) ? $dist : 0;
1010    
1011       if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef  }
1012       if (&is_FIG_tip( $node ) )
1013            {
1014             my $d = $dist + $node->[1];
1015             push( @tipList, ($node, $d) );
1016            }
1017     else {     else {
1018    
1019            $dist += $node->[1];
1020         foreach $child (@{$node->[3]})         foreach $child (@{$node->[3]})
1021           { &collect_all_tips($child,$tipList); }            { &collect_tips_and_dist($child, $dist, @tipList);}
1022            #now backtracking
1023            $parent = $node->[2];
1024            $dist -= $parent->[1];
1025       }
1026       @tipList;
1027    }
1028    
1029    sub sort_list_of_pairs {
1030    # gets a list of the form a1, a2, b1, b2, c1, c2 ... where x1, x2 are
1031    # two fields for same object, also x1 is a ref and x2 is a string
1032    # we sort in ascending order by  the second field x2
1033     my ( @rest ) = @_;
1034     my $mat;
1035     my $i=1;
1036     while (@rest) {
1037      $mat[$i][1] = shift @rest;
1038      $mat[$i][2] = shift @rest;
1039      $i++;
1040     }     }
1041     return (@$tipList);   my @pairs;
1042     for (my $k=1; $k < $i; $k++) {
1043        for (my $l=$k; $l < $i; $l++) {
1044             if ($mat[$l][2] < $mat[$k][2]) {
1045                $temp2 = $mat[$k][2];      $temp1 = $mat[$k][1];
1046                $mat[$k][2] = $mat[$l][2]; $mat[$k][1] = $mat[$l][1];
1047                $mat[$l][2] = $temp2;      $mat[$l][1] = $temp1;
1048              }
1049         }
1050         push (@pairs, ($mat[$k]->[1], $mat[$k]->[2]) );
1051     }
1052     @pairs;
1053  }  }
1054    
1055  sub collect_all_nodes {  sub collect_all_nodes {
1056  # collects all non-tip noderefs of subtree rooted at $node  # collects all non-tip noderefs of subtree rooted at $node
1057     ($node , $nodeList) = @_;     ($node , @nodeList) = @_;
1058     my $child;     my $child;
1059     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef;  }     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef;  }
1060     if (&is_FIG_tip( $node ) )    { undef  }     if (&is_FIG_tip( $node ) )    { undef  }
1061     else {     else {
1062         push (@$nodeList, $node);         push (@nodeList, $node);
1063           foreach $child (@{$node->[3]})
1064             { &collect_all_nodes($child,@nodeList); }
1065       }
1066       return @nodeList;
1067    }
1068    
1069    sub collect_all_noderef {
1070    # collects all noderefs, leaf and nonleaf,
1071    # of subtree rooted at $node
1072       ($node , @nodeList) = @_;
1073       my $child;
1074       array_ref($node) || undef;
1075       if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef;  }
1076       else
1077          {
1078           push (@nodeList, $node);
1079         foreach $child (@{$node->[3]})         foreach $child (@{$node->[3]})
1080           { &collect_all_nodes($child,$nodeList); }           { &collect_all_noderef($child,@nodeList); }
1081     }     }
1082     return ($nodeList);  
1083       return @nodeList;
1084  }  }
1085    
1086    sub tipref_to_tipname {
1087    # gets a list of tip refs and returns a list of tip labels
1088        map { get_FIG_label($_) } @_ ;
1089    }
1090    
1091  sub tips_down_within_dist {  sub tips_down_within_dist {
1092  # collects tips of tree rooted at $node that are within $dist  # collects tips of tree rooted at $node that are within $dist
# Line 1043  Line 1214 
1214     $tot? $tot : undef;     $tot? $tot : undef;
1215  }  }
1216    
1217    sub maxref_of_subtree
1218    {
1219       ($node) = @_;
1220       my ($t, $x) = most_distant_tip_ref($node,1);
1221       return ($t, $x);
1222    }
1223    
1224    sub minref_of_subtree
1225    {
1226       ($node) = @_;
1227       my ($t, $x) = closest_tip_ref($node,1);
1228       return ($t, $x);
1229    }
1230    
1231  sub get_path_to_first_tip {  sub get_path_to_first_tip {
1232     ($node, $path) = @_;     ($node, $path) = @_;
1233     my $child;     my $child;
# Line 1108  Line 1293 
1293  sub FIG_path_to_node {  sub FIG_path_to_node {
1294  # node could be $tipname | [$tipname] |  $t1 $t2 $t3  # node could be $tipname | [$tipname] |  $t1 $t2 $t3
1295      my ($node, $tip1, $tip2, $tip3) = @_;      my ($node, $tip1, $tip2, $tip3) = @_;
1296      print "\nargs node= $node t1= $tip1 t2= $tip2 t3= $tip3";      #print "\nargs node= $node t1= $tip1 t2= $tip2 t3= $tip3";
1297      array_ref( $node ) && defined( $tip1 ) || return ();      array_ref( $node ) && defined( $tip1 ) || return ();
1298    
1299      # Allow arg 2 to be an array reference      # Allow arg 2 to be an array reference
# Line 1116  Line 1301 
1301    
1302      my @p1 = FIG_path_to_tip($node, $tip1);      my @p1 = FIG_path_to_tip($node, $tip1);
1303      @p1 || return ();      @p1 || return ();
1304      print "\npatht1= @p1";      #print "\npatht1= @p1";
1305      defined( $tip2 ) && defined( $tip3 ) || return @p1;      defined( $tip2 ) && defined( $tip3 ) || return @p1;
1306    
1307      my @p2 = FIG_path_to_tip($node, $tip2);      my @p2 = FIG_path_to_tip($node, $tip2);
1308      my @p3 = FIG_path_to_tip($node, $tip3);      my @p3 = FIG_path_to_tip($node, $tip3);
1309    
1310      @p2 && @p3 || return ();      @p2 && @p3 || return ();
1311      print "\npatht2= @p2 patht3= @p3";      #print "\npatht2= @p2 patht3= @p3";
1312      # Find the common prefix for each pair of paths      # Find the common prefix for each pair of paths
1313      my @p12 = common_prefix( \@p1, \@p2 );      my @p12 = common_prefix( \@p1, \@p2 );
1314      my @p13 = common_prefix( \@p1, \@p3 );      my @p13 = common_prefix( \@p1, \@p3 );
# Line 1155  Line 1340 
1340  }  }
1341    
1342  sub most_distant_tip_path {  sub most_distant_tip_path {
1343      my ($node, $notroot) = @_;      my ($node) = @_;
1344        my ($tmax, $xmax) = most_distant_tip_ref($node);
1345      my $imax = get_FIG_numDesc( $node );      my @pmax = FIG_path_to_node_ref($node, $tmax);
1346      my $xmax = ( $imax > 0 ) ? -1 : 0;      @pmax;
     my @pmax = ();  
     for ( my $i = 1; $i <= $imax; $i++ ) {  
         my ($x, @path) = most_distant_tip_path(get_FIG_ith_desc($node, $i),1 );  
         if ( $x > $xmax ) { $xmax = $x; @pmax = @path; }  
1347      }      }
1348    sub closest_tip_path {
1349      my $x = $notroot ? get_FIG_X( $node ) : 0;      my ($node) = @_;
1350      $xmax += defined( $x ) ? $x : 0;            #  Convert undefined to 1      my ($tmin, $xmin) = closest_tip_ref($node);
1351      ( $xmax, $node, @pmax );      my @pmin = FIG_path_to_node_ref($node, $tmin);
1352        @pmin;
1353  }  }
1354    sub closest_tip_ref {
1355  sub most_distant_tip_ref {      my ($node) = @_;
1356      my ($node, $notroot) = @_;      my @tpairs = sort_list_of_pairs( collect_tips_and_dist($node) );
1357        my $tmin = shift @tpairs;
1358      my $imax =  get_FIG_numDesc( $node );      my $xmin = shift @tpairs;
1359      my $xmax = ( $imax > 0 ) ? -1 : 0;      ( $tmin, $xmin );
     my $tmax = $node;  
     for ( my $i = 1; $i <= $imax; $i++ ) {  
         my ($t, $x) = most_distant_tip_ref(get_FIG_ith_desc($node, $i), 1 );  
         if ( $x > $xmax ) { $xmax = $x; $tmax = $t }  
1360      }      }
1361    
1362      my $x = $notroot ? get_FIG_X( $node ) : 0;  sub most_distant_tip_ref {
1363      $xmax += defined( $x ) ? $x : 0;      my ($node) = @_;
1364        my @tpairs = sort_list_of_pairs( collect_tips_and_dist($node) );
1365        my $xmax = pop @tpairs;
1366        my $tmax = pop @tpairs;
1367      ( $tmax, $xmax );      ( $tmax, $xmax );
1368  }  }
1369    
# Line 1191  Line 1372 
1372      ( get_FIG_label( $tipref ), $xmax )      ( get_FIG_label( $tipref ), $xmax )
1373  }  }
1374    
1375    sub closest_tip_name {
1376        my ($tipref, $xmin) = closest_tip_ref( $_[0] );
1377        ( get_FIG_label( $tipref ), $xmin )
1378    }
1379    
1380  sub FIG_dist_tip_to_tip {  sub FIG_dist_tip_to_tip {
1381    # tip1 and tip2 should be tip labels and contained in subtree rooted at $node
1382      my ($node, $tip1, $tip2) = @_;      my ($node, $tip1, $tip2) = @_;
1383    
1384      array_ref( $node ) && defined( $tip1 )      array_ref( $node ) && defined( $tip1 )
# Line 1204  Line 1390 
1390    
1391      # Find the unique suffixes of the two paths      # Find the unique suffixes of the two paths
1392      my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 );      my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 );
1393        my $d1 = @$suf1 ? distance_along_path( @$suf1 ) : 0;
1394      my $d1 = @$suf1 ? distance_along_path( $suf1 ) : 0;      my $d2 = @$suf2 ? distance_along_path( @$suf2 ) : 0;
     my $d2 = @$suf2 ? distance_along_path( $suf2 ) : 0;  
1395      defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;      defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1396  }  }
1397    
1398  sub FIG_dist_node_to_node {  sub FIG_dist_node_to_node {
1399  # both node1 and node2 must be in node's subtree  # both node1 and node2 must be refs and in the subtree rooted at $node
1400  # node1 ,node2 could be= $tipname | [$tipname] |  $t1 $t2 $t3  # node1 ,node2 could be= $tipname | [$tipname] |  $t1 $t2 $t3
1401      my ($node, $node1, $node2) = @_;      my ($node, $node1, $node2) = @_;
1402    
# Line 1382  Line 1567 
1567      }      }
1568  }  }
1569    
1570    sub FIG_split_tree {
1571    # we split the tree at random into subregions, AKA bunches
1572    # Our approach: at least one region is sure to contain
1573    # the tree's representative leaves; the other regions
1574    # will contain leaves that were selected at random
1575    
1576      my ($fig, $numBunches) = @_;
1577      my @trees;
1578      if (! array_ref($fig)) { print "\split info missing, no tree"; return undef;}
1579      if (! $numBunches) { print "\nsplit info missing, no numbunch"; return undef;}
1580      if ($numBunches == 1) {print "\nno split, numbunch is one";return $fig; }
1581    
1582    
1583      # so far, we will use these heuristics; later on
1584      # we need to replace this one with min spanning tree
1585      # or some such
1586      my $size = FIG_region_size($fig, $numBunches );
1587      $trees[1] = FIG_representative_tree(FIG_copy_tree($fig), $size );
1588      for (my $i = 2; $i <= $numBunches; $i++) {
1589        $trees[$i] = &get_random_minitree(FIG_copy_tree($fig),$size );
1590      }
1591      return @trees;
1592    }
1593    
1594    sub get_random_minitree {
1595      my ($tree,$size) = @_;
1596      array_ref($tree) && defined($size) || undef;
1597      my $tip;
1598      my @tips = FIG_tips_of_tree($tree);
1599      my @randTips = random_order(@tips);
1600      my @minitree = splice @randTips, 0,$size;
1601      my @tipsToremove = set_difference(\@tips, \@minitree);
1602      if (! @tipsToremove) {return undef;}
1603      foreach $tip (@tipsToremove) { FIG_prune_tip($tree,$tip);  }
1604      return $tree;
1605    }
1606    
1607    
1608  sub FIG_representative_tree {  sub FIG_representative_tree {
1609  # thins the tree off of small tips until tree is of specified size  # thins the tree off of small tips until tree is of specified size
1610     my ($tree, $size) = @_;     my ($tree, $size) = @_;
1611       my $tip;
1612     array_ref($tree) && defined($size) || undef;     array_ref($tree) && defined($size) || undef;
1613     my @tips = collect_all_tips( $tree );     my @tiprefs = collect_all_tips( $tree );
1614     my @sortedtips = sort by_distance @tips;     my @sortedtips = sort by_distance @tiprefs;
1615     my $to_remove = @tips - $size;     my $to_remove = (scalar @sortedtips) - $size;
1616     if ($to_remove <= 0) { return $tree }     if ($to_remove <= 0) { return $tree; }
1617       my @tips= tipref_to_tipname(@sortedtips);
1618     while ($to_remove > 0)     while ($to_remove > 0)
1619       {       {
1620         my $tip = shift @sortedtips;         $tip = shift @tips;
1621         FIG_prune_tip($tree,$tip);         FIG_prune_tip($tree,$tip);
1622         $to_remove--;         $to_remove--;
1623       }       }
# Line 1465  Line 1690 
1690  # tip node is deleted,  then tree is normalized w/ local operations  # tip node is deleted,  then tree is normalized w/ local operations
1691  # input could be tipref or tipname  # input could be tipref or tipname
1692    my ($tree, $tip1) = @_;    my ($tree, $tip1) = @_;
1693    
1694    array_ref($tree) && defined($tip1) || undef;    array_ref($tree) && defined($tip1) || undef;
1695    
1696    if (! array_ref($tip1) )    if (! array_ref($tip1) )
1697       { # arg 2 is a tipname; we need a tipref       { # arg 2 is a tipname; we need a tipref
1698          $tip1 = get_FIG_tipref($tree,$tip1);          $tip1 = get_FIG_tipref($tree,$tip1);
1699       }       }
1700    is_FIG_tip($tip1) || undef;  
1701      if (!is_FIG_tip($tip1)) {print "\ntip not in tree: ";
1702                               print $tip1;return undef;}
1703    my $parent = $tip1->[2];    my $parent = $tip1->[2];
1704    array_ref($parent) || undef;    if (! array_ref($parent)) {print "\nlast tip, now empty tree";return undef; }
1705    my $tips = $parent->[3];    my $children = $parent->[3];
1706      my @leaves;
1707    my $tip2;    my $tip2;
1708    if ( (@$tips == 3) || (@$tips == 1) )    my $child;
1709    
1710      #some of the children may not be tips; let's find out
1711      foreach $child (@{$parent->[3]})
1712        { if ($child->[0]) { push (@leaves,$child); } }
1713    
1714      if (scalar @leaves == 3)
1715      {      {
1716        # just delete tip from the parent's descList        # unrooted tree. Delete tip from the parent's descList
1717        delete_FIG_descRef($parent,$tip1);        delete_FIG_descRef($parent,$tip1);
1718          return tree;
1719      }      }
1720    elsif (@$tips == 2)    if (scalar @leaves == 2)
1721      {      {
1722        # need to collapse tip2 and tip1's parent into one        # need to collapse tip2 and tip1's parent nodes into one
1723        $tip2 = ($tips->[0] eq $tip1) ? $tips->[1] : $tips->[0];        ($tip2) = pop @leaves;
1724        $parent->[0] = join($parent->[0],$tip2->[0]);        if ($tip2->[0] eq $tip1->[0]) { $tip2= pop @leaves; }
1725          $parent->[0] = $tip2->[0];
1726        $parent->[1] += $tip2->[1];        $parent->[1] += $tip2->[1];
1727        $parent->[3] = [];        $parent->[3] = undef;
1728        add_FIG_node_attrib($parent, $tip2->[4]);        if (array_ref($tip2->[4]) )
1729        add_FIG_branch_attrib($parent, $tip2->[5]);        {add_FIG_node_attrib($parent, $tip2->[4]);}
1730          if (array_ref( $tip2->[5]) )
1731          {add_FIG_branch_attrib($parent, $tip2->[5]); }
1732          return tree;
1733      }      }
1734    else {return undef }    if (scalar @leaves == 1)
1735    $parent;      {
1736          if (@$children == 1) {
1737            # just delete tip from the parent's descList
1738            $parent->[3] = undef;
1739            return tree;
1740          }
1741          else {
1742            # we have one tip and one node hanging out of parent node
1743            # we need to collapse two nodes in a row into one
1744            FIG_prune_node($parent,$tip1);
1745            return tree;
1746          }
1747        }
1748       if (scalar @leaves == 0)
1749        { print "\nabsurd, no tips"; return tree; }
1750      return $tree;
1751  }  }
1752    
1753    
# Line 1514  Line 1770 
1770      { # need to collapse parent and sibling into one";      { # need to collapse parent and sibling into one";
1771        $node2 = ($children->[0] eq $node1) ?        $node2 = ($children->[0] eq $node1) ?
1772                 $children->[1] : $children->[0];                 $children->[1] : $children->[0];
1773        $node2->[0] = join($node2->[0],$parent->[0]);        $node2->[0] = $parent->[0];
1774        $node2->[1] += $parent->[1];        $node2->[1] += $parent->[1];
1775        $node2->[2] = $grandp;        $node2->[2] = $grandp;
1776        add_FIG_node_attrib($node2,$parent->[4]);        add_FIG_node_attrib($node2,$parent->[4]);
# Line 1527  Line 1783 
1783  }  }
1784    
1785  sub normalize_FIG_tree {  sub normalize_FIG_tree {
1786    # performs global operations on tree to get rid of nodes
1787    # with a single child
1788      my ($node) = @_;      my ($node) = @_;
1789    
1790      my @descends = get_FIG_descList( $node );      my @descends = get_FIG_descList( $node );
# Line 1888  Line 2146 
2146  #=========================================================================  #=========================================================================
2147  #  overbeek_to_FIGtree  #  overbeek_to_FIGtree
2148  #-------------------------------------------------------------------------  #-------------------------------------------------------------------------
2149    
2150  sub overbeek_to_FIGtree {  sub overbeek_to_FIGtree {
2151      my ( $ro_node, $parent ) = @_;      my ( $ro_node, $parent ) = @_;
2152      ( ref( $ro_node ) eq "ARRAY" ) && ( @$ro_node ) || return undef;      ( ref( $ro_node ) eq "ARRAY" ) && ( @$ro_node ) || return undef;

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.3

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3