[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.2, Fri Jul 22 17:41:36 2005 UTC
# Line 32  Line 32 
32          FIG_nodes_within_dist          FIG_nodes_within_dist
33          FIG_num_nodes          FIG_num_nodes
34          FIG_num_tips          FIG_num_tips
35            FIG_num_bunches
36            FIG_path_length
37          FIG_path_to_first_tip          FIG_path_to_first_tip
38          FIG_path_to_node          FIG_path_to_node
39          FIG_path_to_node_ref          FIG_path_to_node_ref
# Line 43  Line 45 
45          FIG_prune_node          FIG_prune_node
46          FIG_prune_tip          FIG_prune_tip
47          FIG_random_order_tree          FIG_random_order_tree
48            FIG_region_size
49          FIG_representative_tree          FIG_representative_tree
50          FIG_reverse_tree          FIG_reverse_tree
51          FIG_shared_tips          FIG_shared_tips
52            FIG_split_tree
53          FIG_steps_to_node          FIG_steps_to_node
54          FIG_steps_to_root          FIG_steps_to_root
55          FIG_steps_to_fist_tip          FIG_steps_to_fist_tip
# Line 53  Line 57 
57          FIG_tips_of_tree          FIG_tips_of_tree
58          FIG_tips_within_dist          FIG_tips_within_dist
59          FIG_tips_within_steps          FIG_tips_within_steps
60            FIG_tree_diameter
61          FIG_tree_length          FIG_tree_length
62            FIG_tree_depth
63            FIG_tree_size
64          add_FIG_branch_attrib          add_FIG_branch_attrib
65          add_FIG_desc          add_FIG_desc
66          add_FIG_node_attrib          add_FIG_node_attrib
# Line 61  Line 68 
68          collapse_FIG_tree          collapse_FIG_tree
69          collect_all_tips          collect_all_tips
70          collect_all_nodes          collect_all_nodes
71            collect_tips_and_dist
72          delete_elm          delete_elm
73          delete_FIG_branch_attrib          delete_FIG_branch_attrib
74          delete_FIG_descRef          delete_FIG_descRef
# Line 113  Line 121 
121          most_distant_tip_path          most_distant_tip_path
122          most_distant_tip_name          most_distant_tip_name
123          most_distant_tip_ref          most_distant_tip_ref
         most_distant_tip_path  
124          normalize_FIG_tree          normalize_FIG_tree
125          nodes_down_within_dist          nodes_down_within_dist
126          nodes_up_within_dist          nodes_up_within_dist
# Line 140  Line 147 
147          set_FIG_ith_node_attrib          set_FIG_ith_node_attrib
148          set_FIG_ith_branch_attrib          set_FIG_ith_branch_attrib
149          set_FIG_undef_branch          set_FIG_undef_branch
150            sort_list_of_pairs
151          std_unrooted_FIG          std_unrooted_FIG
152          tips_down_within_steps          tips_down_within_steps
153          tips_up_within_steps          tips_up_within_steps
# Line 639  Line 647 
647  #  statistics functions -- tree operations without side effects  #  statistics functions -- tree operations without side effects
648  #------------------------------------------------------------------  #------------------------------------------------------------------
649  sub FIG_tree_length {  sub FIG_tree_length {
650    # adds up the distances of all nodes of tree
651      my ($node, $notroot) = @_;      my ($node, $notroot) = @_;
652      array_ref( $node) || return;      array_ref( $node) || return;
653      my $x = $notroot ? get_FIG_X( $node ) : 0;      my $x = $notroot ? get_FIG_X( $node ) : 0;
654      defined( $x ) || ( $x = 1 );      defined( $x ) || ( $x = 1 );
655        #print "\nat node = $node with value of x = $x";
656      my $imax = get_FIG_numDesc($node);      my $imax = get_FIG_numDesc($node);
657      for ( my $i = 1; $i <= $imax; $i++ ) {      for ( my $i = 1; $i <= $imax; $i++ ) {
658          $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 660 
660      $x;      $x;
661  }  }
662    
663    sub FIG_tree_diameter {
664    # locates the two most distant tips in tree and
665    # calculates distance of its path
666      my ($fig) = @_;
667      my @tpairs = sort_list_of_pairs( collect_tips_and_dist($fig) );
668      my $t1 = shift @tpairs;
669      my $x1 = shift @tpairs;
670      my $x2 = pop @tpairs;
671      my $t2 = pop @tpairs;
672      &FIG_dist_tip_to_tip($fig,$t1->[0],$t2->[0]);
673    }
674    
675    sub FIG_path_length {
676    # given a path, it calculates the distance/length of it
677    # check distance_along_path to get path length given
678    # two points rather than a path like it is here
679        my $length=0;
680        map { $length += get_FIG_X($_) } @_;
681        return $length;
682    }
683    sub FIG_tree_depth {
684    # given a tree -its root node- it calculates depth of it;
685    # or in other words, the number of internal nodes between
686    # the root and its most distant tip
687       my ($node) = @_;
688       my $path = &most_distant_tip_path($node,1);
689       return $path;
690    }
691    
692    sub FIG_tree_size {
693    # number of internal and external nodes of the tree
694    # this way: takes n^2
695    #  return (FIG_num_nodes(@_) + FIG_num_tips(@_));
696    #this other way takes n
697       my @nodes = collect_all_noderef(@_);
698       return scalar @nodes;
699    }
700    
701    sub FIG_num_bunches {
702    # a bunch is a subregion or split of the tree
703    # the right number of subregions is a heuristic
704    # in our case, we choose it based on the size of the tree
705       my ($fig) = @_;
706       my $lowN = int (log FIG_num_tips($fig));
707       my $hiN = &FIG_tree_depth($fig);
708       my $midN = 3;
709       my @array = ($lowN, $hiN, $midN);
710       sort { $a <=> $b } @array;
711       my $numBunches = pop @array;
712       while ($numBunches <= 0) { $numBunches = pop @array; }
713       return $numBunches;
714    }
715    
716    sub FIG_region_size {
717    # roughly speaking, we divide the tips evenly among the regions
718    # note, other heuristics can be implemented here
719       my ($fig, $numBunches) = @_;
720      if (! array_ref($fig)) { print "\split info missing, no tree"; return undef;}
721      if (! $numBunches) { print "\nsplit info missing, no numbunch"; return undef;}
722      if ($numBunches == 1) {print "\nnumbunch is one";return $fig; }
723    
724       my @tips = collect_all_tips($fig);
725       my $numtips = scalar @tips;
726       my $regionSize = int ($numtips / $numBunches);
727       if ($regionSize <= 0) { print "\nerror calculating size"; return undef; }
728       else { return $regionSize; }
729    }
730    
731  sub FIG_nodes_of_tree {  sub FIG_nodes_of_tree {
732  # returns list of non-tip node references  # returns list of non-tip node references
733     &collect_all_nodes( @_ );     &collect_all_nodes( @_ );
# Line 788  Line 865 
865  }  }
866    
867  sub FIG_num_tips {  sub FIG_num_tips {
868  # tot tips of tree rooted at $fig  # tot tips/leaves of tree rooted at $fig
869     ($fig)= @_;     ($fig)= @_;
870     my $tips =  &collect_all_tips($fig, []);     my @tips =  &collect_all_tips($fig);
871     return scalar @$tips;     return scalar @tips;
872  }  }
873    
874  sub FIG_num_nodes {  sub FIG_num_nodes {
875  # tot non-tip nodes of tree rooted at $fig  # tot non-tip nodes of tree rooted at $fig
876     ($fig) = @_;     ($fig) = @_;
877     my $nodes = &collect_all_nodes($fig, []);     my @nodes = collect_all_nodes($fig);
878     return scalar @$nodes;     return  scalar @nodes;
879  }  }
880    
881    
882    
883  sub FIG_first_tip {  sub FIG_first_tip {
884  #first tip along path of $node  #first tip along path of $node
885     my ($node) = @_;     my ($node) = @_;
# Line 891  Line 970 
970    
971  sub collect_all_tips {  sub collect_all_tips {
972  # collects tiprefs of subtree rooted at $node  # collects tiprefs of subtree rooted at $node
973     ($node , $tipList) = @_;     ($node , @tipList) = @_;
974     my $child;     my $child;
975     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef  }     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef  }
976     if (&is_FIG_tip( $node ) )  {  push( @$tipList, $node )}     if (&is_FIG_tip( $node ) )  {  push( @tipList, $node )}
977     else {     else {
978         foreach $child (@{$node->[3]})         foreach $child (@{$node->[3]})
979           { &collect_all_tips($child,$tipList); }           { &collect_all_tips($child,@tipList); }
980     }     }
981     return (@$tipList);     return @tipList;
982    }
983    
984    sub collect_tips_and_dist {
985    # collects tiprefs of subtree rooted at $node
986    # it also calculates accum. distance from root to each tip
987       $node = shift @_;
988       my $dist = shift @_;
989       @tipList = @_;
990       my $child;
991       my $parent;
992       $dist = defined($dist) ? $dist : 0;
993    
994       if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef  }
995       if (&is_FIG_tip( $node ) )
996            {
997             my $d = $dist + $node->[1];
998             push( @tipList, ($node, $d) );
999            }
1000       else {
1001    
1002            $dist += $node->[1];
1003            foreach $child (@{$node->[3]})
1004              { &collect_tips_and_dist($child, $dist, @tipList);}
1005            #now backtracking
1006            $parent = $node->[2];
1007            $dist -= $parent->[1];
1008       }
1009       @tipList;
1010    }
1011    
1012    sub sort_list_of_pairs {
1013    # gets a list of the form a1, a2, b1, b2, c1, c2 ... where x1, x2 are
1014    # two fields for same object, also x1 is a ref and x2 is a string
1015    # we sort in ascending order by  the second field x2
1016     my ( @rest ) = @_;
1017     my $mat;
1018     my $i=1;
1019     while (@rest) {
1020      $mat[$i][1] = shift @rest;
1021      $mat[$i][2] = shift @rest;
1022      $i++;
1023     }
1024     my @pairs;
1025     for (my $k=1; $k < $i; $k++) {
1026        for (my $l=$k; $l < $i; $l++) {
1027             if ($mat[$l][2] < $mat[$k][2]) {
1028                $temp2 = $mat[$k][2];      $temp1 = $mat[$k][1];
1029                $mat[$k][2] = $mat[$l][2]; $mat[$k][1] = $mat[$l][1];
1030                $mat[$l][2] = $temp2;      $mat[$l][1] = $temp1;
1031              }
1032         }
1033         push (@pairs, ($mat[$k]->[1], $mat[$k]->[2]) );
1034     }
1035     @pairs;
1036  }  }
1037    
1038  sub collect_all_nodes {  sub collect_all_nodes {
1039  # collects all non-tip noderefs of subtree rooted at $node  # collects all non-tip noderefs of subtree rooted at $node
1040     ($node , $nodeList) = @_;     ($node , @nodeList) = @_;
1041     my $child;     my $child;
1042     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef;  }     if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef;  }
1043     if (&is_FIG_tip( $node ) )    { undef  }     if (&is_FIG_tip( $node ) )    { undef  }
1044     else {     else {
1045         push (@$nodeList, $node);         push (@nodeList, $node);
1046           foreach $child (@{$node->[3]})
1047             { &collect_all_nodes($child,@nodeList); }
1048       }
1049       return @nodeList;
1050    }
1051    
1052    sub collect_all_noderef {
1053    # collects all noderefs, leaf and nonleaf,
1054    # of subtree rooted at $node
1055       ($node , @nodeList) = @_;
1056       my $child;
1057       array_ref($node) || undef;
1058       if ((! &is_FIG_node( $node )) && (! &is_FIG_tip($node))) { undef;  }
1059       else
1060          {
1061           push (@nodeList, $node);
1062         foreach $child (@{$node->[3]})         foreach $child (@{$node->[3]})
1063           { &collect_all_nodes($child,$nodeList); }           { &collect_all_noderef($child,@nodeList); }
1064     }     }
1065     return ($nodeList);  
1066       return @nodeList;
1067  }  }
1068    
1069    sub tipref_to_tipname {
1070    # gets a list of tip refs and returns a list of tip labels
1071        map { get_FIG_label($_) } @_ ;
1072    }
1073    
1074  sub tips_down_within_dist {  sub tips_down_within_dist {
1075  # 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 1197 
1197     $tot? $tot : undef;     $tot? $tot : undef;
1198  }  }
1199    
1200    sub maxref_of_subtree
1201    {
1202       ($node) = @_;
1203       my ($t, $x) = most_distant_tip_ref($node,1);
1204       return ($t, $x);
1205    }
1206    
1207    sub minref_of_subtree
1208    {
1209       ($node) = @_;
1210       my ($t, $x) = closest_tip_ref($node,1);
1211       return ($t, $x);
1212    }
1213    
1214  sub get_path_to_first_tip {  sub get_path_to_first_tip {
1215     ($node, $path) = @_;     ($node, $path) = @_;
1216     my $child;     my $child;
# Line 1108  Line 1276 
1276  sub FIG_path_to_node {  sub FIG_path_to_node {
1277  # node could be $tipname | [$tipname] |  $t1 $t2 $t3  # node could be $tipname | [$tipname] |  $t1 $t2 $t3
1278      my ($node, $tip1, $tip2, $tip3) = @_;      my ($node, $tip1, $tip2, $tip3) = @_;
1279      print "\nargs node= $node t1= $tip1 t2= $tip2 t3= $tip3";      #print "\nargs node= $node t1= $tip1 t2= $tip2 t3= $tip3";
1280      array_ref( $node ) && defined( $tip1 ) || return ();      array_ref( $node ) && defined( $tip1 ) || return ();
1281    
1282      # Allow arg 2 to be an array reference      # Allow arg 2 to be an array reference
# Line 1116  Line 1284 
1284    
1285      my @p1 = FIG_path_to_tip($node, $tip1);      my @p1 = FIG_path_to_tip($node, $tip1);
1286      @p1 || return ();      @p1 || return ();
1287      print "\npatht1= @p1";      #print "\npatht1= @p1";
1288      defined( $tip2 ) && defined( $tip3 ) || return @p1;      defined( $tip2 ) && defined( $tip3 ) || return @p1;
1289    
1290      my @p2 = FIG_path_to_tip($node, $tip2);      my @p2 = FIG_path_to_tip($node, $tip2);
1291      my @p3 = FIG_path_to_tip($node, $tip3);      my @p3 = FIG_path_to_tip($node, $tip3);
1292    
1293      @p2 && @p3 || return ();      @p2 && @p3 || return ();
1294      print "\npatht2= @p2 patht3= @p3";      #print "\npatht2= @p2 patht3= @p3";
1295      # Find the common prefix for each pair of paths      # Find the common prefix for each pair of paths
1296      my @p12 = common_prefix( \@p1, \@p2 );      my @p12 = common_prefix( \@p1, \@p2 );
1297      my @p13 = common_prefix( \@p1, \@p3 );      my @p13 = common_prefix( \@p1, \@p3 );
# Line 1155  Line 1323 
1323  }  }
1324    
1325  sub most_distant_tip_path {  sub most_distant_tip_path {
1326      my ($node, $notroot) = @_;      my ($node) = @_;
1327        my ($tmax, $xmax) = most_distant_tip_ref($node);
1328      my $imax = get_FIG_numDesc( $node );      my @pmax = FIG_path_to_node_ref($node, $tmax);
1329      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; }  
1330      }      }
1331    sub closest_tip_path {
1332      my $x = $notroot ? get_FIG_X( $node ) : 0;      my ($node) = @_;
1333      $xmax += defined( $x ) ? $x : 0;            #  Convert undefined to 1      my ($tmin, $xmin) = closest_tip_ref($node);
1334      ( $xmax, $node, @pmax );      my @pmin = FIG_path_to_node_ref($node, $tmin);
1335        @pmin;
1336  }  }
1337    sub closest_tip_ref {
1338  sub most_distant_tip_ref {      my ($node) = @_;
1339      my ($node, $notroot) = @_;      my @tpairs = sort_list_of_pairs( collect_tips_and_dist($node) );
1340        my $tmin = shift @tpairs;
1341      my $imax =  get_FIG_numDesc( $node );      my $xmin = shift @tpairs;
1342      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 }  
1343      }      }
1344    
1345      my $x = $notroot ? get_FIG_X( $node ) : 0;  sub most_distant_tip_ref {
1346      $xmax += defined( $x ) ? $x : 0;      my ($node) = @_;
1347        my @tpairs = sort_list_of_pairs( collect_tips_and_dist($node) );
1348        my $xmax = pop @tpairs;
1349        my $tmax = pop @tpairs;
1350      ( $tmax, $xmax );      ( $tmax, $xmax );
1351  }  }
1352    
# Line 1191  Line 1355 
1355      ( get_FIG_label( $tipref ), $xmax )      ( get_FIG_label( $tipref ), $xmax )
1356  }  }
1357    
1358    sub closest_tip_name {
1359        my ($tipref, $xmin) = closest_tip_ref( $_[0] );
1360        ( get_FIG_label( $tipref ), $xmin )
1361    }
1362    
1363  sub FIG_dist_tip_to_tip {  sub FIG_dist_tip_to_tip {
1364    # tip1 and tip2 should be tip labels and contained in subtree rooted at $node
1365      my ($node, $tip1, $tip2) = @_;      my ($node, $tip1, $tip2) = @_;
1366    
1367      array_ref( $node ) && defined( $tip1 )      array_ref( $node ) && defined( $tip1 )
# Line 1204  Line 1373 
1373    
1374      # Find the unique suffixes of the two paths      # Find the unique suffixes of the two paths
1375      my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 );      my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 );
1376        my $d1 = @$suf1 ? distance_along_path( @$suf1 ) : 0;
1377      my $d1 = @$suf1 ? distance_along_path( $suf1 ) : 0;      my $d2 = @$suf2 ? distance_along_path( @$suf2 ) : 0;
     my $d2 = @$suf2 ? distance_along_path( $suf2 ) : 0;  
1378      defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;      defined( $d1 ) && defined( $d2 ) ? $d1 + $d2 : undef;
1379  }  }
1380    
1381  sub FIG_dist_node_to_node {  sub FIG_dist_node_to_node {
1382  # both node1 and node2 must be in node's subtree  # both node1 and node2 must be refs and in the subtree rooted at $node
1383  # node1 ,node2 could be= $tipname | [$tipname] |  $t1 $t2 $t3  # node1 ,node2 could be= $tipname | [$tipname] |  $t1 $t2 $t3
1384      my ($node, $node1, $node2) = @_;      my ($node, $node1, $node2) = @_;
1385    
# Line 1382  Line 1550 
1550      }      }
1551  }  }
1552    
1553    sub FIG_split_tree {
1554    # we split the tree at random into subregions, AKA bunches
1555    # Our approach: at least one region is sure to contain
1556    # the tree's representative leaves; the other regions
1557    # will contain leaves that were selected at random
1558    
1559      my ($fig, $numBunches) = @_;
1560      my @trees;
1561      if (! array_ref($fig)) { print "\split info missing, no tree"; return undef;}
1562      if (! $numBunches) { print "\nsplit info missing, no numbunch"; return undef;}
1563      if ($numBunches == 1) {print "\nno split, numbunch is one";return $fig; }
1564    
1565    
1566      # so far, we will use these heuristics; later on
1567      # we need to replace this one with min spanning tree
1568      # or some such
1569      my $size = FIG_region_size($fig, $numBunches );
1570      $trees[1] = FIG_representative_tree(FIG_copy_tree($fig), $size );
1571      for (my $i = 2; $i <= $numBunches; $i++) {
1572        $trees[$i] = &get_random_minitree(FIG_copy_tree($fig),$size );
1573      }
1574      return @trees;
1575    }
1576    
1577    sub get_random_minitree {
1578      my ($tree,$size) = @_;
1579      array_ref($tree) && defined($size) || undef;
1580      my $tip;
1581      my @tips = FIG_tips_of_tree($tree);
1582      my @randTips = random_order(@tips);
1583      my @minitree = splice @randTips, 0,$size;
1584      my @tipsToremove = set_difference(\@tips, \@minitree);
1585      if (! @tipsToremove) {return undef;}
1586      foreach $tip (@tipsToremove) { FIG_prune_tip($tree,$tip);  }
1587      return $tree;
1588    }
1589    
1590    
1591  sub FIG_representative_tree {  sub FIG_representative_tree {
1592  # 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
1593     my ($tree, $size) = @_;     my ($tree, $size) = @_;
1594       my $tip;
1595     array_ref($tree) && defined($size) || undef;     array_ref($tree) && defined($size) || undef;
1596     my @tips = collect_all_tips( $tree );     my @tiprefs = collect_all_tips( $tree );
1597     my @sortedtips = sort by_distance @tips;     my @sortedtips = sort by_distance @tiprefs;
1598     my $to_remove = @tips - $size;     my $to_remove = (scalar @sortedtips) - $size;
1599     if ($to_remove <= 0) { return $tree }     if ($to_remove <= 0) { return $tree; }
1600       my @tips= tipref_to_tipname(@sortedtips);
1601     while ($to_remove > 0)     while ($to_remove > 0)
1602       {       {
1603         my $tip = shift @sortedtips;         $tip = shift @tips;
1604         FIG_prune_tip($tree,$tip);         FIG_prune_tip($tree,$tip);
1605         $to_remove--;         $to_remove--;
1606       }       }
# Line 1465  Line 1673 
1673  # tip node is deleted,  then tree is normalized w/ local operations  # tip node is deleted,  then tree is normalized w/ local operations
1674  # input could be tipref or tipname  # input could be tipref or tipname
1675    my ($tree, $tip1) = @_;    my ($tree, $tip1) = @_;
1676    
1677    array_ref($tree) && defined($tip1) || undef;    array_ref($tree) && defined($tip1) || undef;
1678    
1679    if (! array_ref($tip1) )    if (! array_ref($tip1) )
1680       { # arg 2 is a tipname; we need a tipref       { # arg 2 is a tipname; we need a tipref
1681          $tip1 = get_FIG_tipref($tree,$tip1);          $tip1 = get_FIG_tipref($tree,$tip1);
1682       }       }
1683    is_FIG_tip($tip1) || undef;  
1684      if (!is_FIG_tip($tip1)) {print "\ntip not in tree: ";
1685                               print $tip1;return undef;}
1686    my $parent = $tip1->[2];    my $parent = $tip1->[2];
1687    array_ref($parent) || undef;    if (! array_ref($parent)) {print "\nlast tip, now empty tree";return undef; }
1688    my $tips = $parent->[3];    my $children = $parent->[3];
1689      my @leaves;
1690    my $tip2;    my $tip2;
1691    if ( (@$tips == 3) || (@$tips == 1) )    my $child;
1692    
1693      #some of the children may not be tips; let's find out
1694      foreach $child (@{$parent->[3]})
1695        { if ($child->[0]) { push (@leaves,$child); } }
1696    
1697      if (scalar @leaves == 3)
1698      {      {
1699        # just delete tip from the parent's descList        # unrooted tree. Delete tip from the parent's descList
1700        delete_FIG_descRef($parent,$tip1);        delete_FIG_descRef($parent,$tip1);
1701          return tree;
1702      }      }
1703    elsif (@$tips == 2)    if (scalar @leaves == 2)
1704      {      {
1705        # need to collapse tip2 and tip1's parent into one        # need to collapse tip2 and tip1's parent nodes into one
1706        $tip2 = ($tips->[0] eq $tip1) ? $tips->[1] : $tips->[0];        ($tip2) = pop @leaves;
1707        $parent->[0] = join($parent->[0],$tip2->[0]);        if ($tip2->[0] eq $tip1->[0]) { $tip2= pop @leaves; }
1708          $parent->[0] = $tip2->[0];
1709        $parent->[1] += $tip2->[1];        $parent->[1] += $tip2->[1];
1710        $parent->[3] = [];        $parent->[3] = undef;
1711        add_FIG_node_attrib($parent, $tip2->[4]);        if (array_ref($tip2->[4]) )
1712        add_FIG_branch_attrib($parent, $tip2->[5]);        {add_FIG_node_attrib($parent, $tip2->[4]);}
1713          if (array_ref( $tip2->[5]) )
1714          {add_FIG_branch_attrib($parent, $tip2->[5]); }
1715          return tree;
1716      }      }
1717    else {return undef }    if (scalar @leaves == 1)
1718    $parent;      {
1719          if (@$children == 1) {
1720            # just delete tip from the parent's descList
1721            $parent->[3] = undef;
1722            return tree;
1723          }
1724          else {
1725            # we have one tip and one node hanging out of parent node
1726            # we need to collapse two nodes in a row into one
1727            FIG_prune_node($parent,$tip1);
1728            return tree;
1729          }
1730        }
1731       if (scalar @leaves == 0)
1732        { print "\nabsurd, no tips"; return tree; }
1733      return $tree;
1734  }  }
1735    
1736    
# Line 1514  Line 1753 
1753      { # need to collapse parent and sibling into one";      { # need to collapse parent and sibling into one";
1754        $node2 = ($children->[0] eq $node1) ?        $node2 = ($children->[0] eq $node1) ?
1755                 $children->[1] : $children->[0];                 $children->[1] : $children->[0];
1756        $node2->[0] = join($node2->[0],$parent->[0]);        $node2->[0] = $parent->[0];
1757        $node2->[1] += $parent->[1];        $node2->[1] += $parent->[1];
1758        $node2->[2] = $grandp;        $node2->[2] = $grandp;
1759        add_FIG_node_attrib($node2,$parent->[4]);        add_FIG_node_attrib($node2,$parent->[4]);
# Line 1527  Line 1766 
1766  }  }
1767    
1768  sub normalize_FIG_tree {  sub normalize_FIG_tree {
1769    # performs global operations on tree to get rid of nodes
1770    # with a single child
1771      my ($node) = @_;      my ($node) = @_;
1772    
1773      my @descends = get_FIG_descList( $node );      my @descends = get_FIG_descList( $node );
# Line 1888  Line 2129 
2129  #=========================================================================  #=========================================================================
2130  #  overbeek_to_FIGtree  #  overbeek_to_FIGtree
2131  #-------------------------------------------------------------------------  #-------------------------------------------------------------------------
2132    
2133  sub overbeek_to_FIGtree {  sub overbeek_to_FIGtree {
2134      my ( $ro_node, $parent ) = @_;      my ( $ro_node, $parent ) = @_;
2135      ( 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.2

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3