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

Diff of /FigKernelPackages/gjonewicklib.pm

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

revision 1.15, Sun Sep 6 22:38:32 2009 UTC revision 1.21, Sat Aug 21 17:12:51 2010 UTC
# Line 1  Line 1 
1    # This is a SAS component.
2    
3  #  #
4  # Copyright (c) 2003-2007 University of Chicago and Fellowship  # Copyright (c) 2003-2010 University of Chicago and Fellowship
5  # for Interpretations of Genomes. All Rights Reserved.  # for Interpretations of Genomes. All Rights Reserved.
6  #  #
7  # This file is part of the SEED Toolkit.  # This file is part of the SEED Toolkit.
# Line 145  Line 147 
147  #  ( $tipref,  $xmax ) = newick_most_distant_tip_ref( $noderef )  #  ( $tipref,  $xmax ) = newick_most_distant_tip_ref( $noderef )
148  #  ( $tipname, $xmax ) = newick_most_distant_tip_name( $noderef )  #  ( $tipname, $xmax ) = newick_most_distant_tip_name( $noderef )
149  #  #
150    #  Provide a standard name by which two trees can be compared for same topology
151    #
152    #  $stdname = std_tree_name( $tree )
153    #
154  #  Tree tip insertion point (tip is on branch of length x that  #  Tree tip insertion point (tip is on branch of length x that
155  #  is inserted into branch connecting node1 and node2, a distance  #  is inserted into branch connecting node1 and node2, a distance
156  #  x1 from node1 and x2 from node2):  #  x1 from node1 and x2 from node2):
# Line 325  Line 331 
331    
332          newick_tip_insertion_point          newick_tip_insertion_point
333    
334          std_newick_name          std_tree_name
335    
336          path_to_tip          path_to_tip
337          path_to_named_node          path_to_named_node
# Line 434  Line 440 
440  #  Internally used definitions  #  Internally used definitions
441  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
442    
443  sub array_ref { ref( $_[0] ) eq "ARRAY" }  sub array_ref { $_[0] && ref( $_[0] ) eq 'ARRAY' }
444  sub hash_ref  { ref( $_[0] ) eq "HASH"  }  sub hash_ref  { $_[0] && ref( $_[0] ) eq 'HASH'  }
445    
446    
447  #===============================================================================  #===============================================================================
# Line 497  Line 503 
503    
504  sub newick_desc_list {  sub newick_desc_list {
505      my $node = $_[0];      my $node = $_[0];
506      ! array_ref( $node      ) ? undef           :      array_ref( $node ) && array_ref( $node->[0] ) ? @{ $node->[0] } : ();
       array_ref( $node->[0] ) ? @{ $node->[0] } :  
                                 ()              ;  
507  }  }
508    
509  sub newick_n_desc {  sub newick_n_desc {
510      my $node = $_[0];      my $node = $_[0];
511      ! array_ref( $node      ) ? undef                  :      array_ref( $node ) && array_ref( $node->[0] ) ? scalar @{ $node->[0] } : 0;
       array_ref( $node->[0] ) ? scalar @{ $node->[0] } :  
                                 0                      ;  
512  }  }
513    
514  sub newick_desc_i {  sub newick_desc_i {
515      my ( $node, $i ) = @_;      my ( $node, $i ) = @_;
516      ! array_ref( $node      ) ? undef              :      array_ref( $node ) && $i && array_ref( $node->[0] ) ? $node->[0]->[$i-1] : undef;
       array_ref( $node->[0] ) ? $node->[0]->[$i-1] :  
                                 undef              ;  
517  }  }
518    
519  sub node_is_tip {  sub node_is_tip {
# Line 1651  Line 1651 
1651    
1652    
1653  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1654    #  Standard name for a Newick tree topology
1655    #
1656    #    $stdname = std_tree_name( $tree )
1657    #
1658    #-------------------------------------------------------------------------------
1659    sub std_tree_name
1660    {
1661        my ( $tree ) = @_;
1662        my ( $mintip ) = sort { lc $a cmp lc $b } newick_tip_list( $tree );
1663        ( std_tree_name_2( reroot_newick_next_to_tip( copy_newick_tree( $tree ), $mintip ) ) )[0];
1664    }
1665    
1666    
1667    #
1668    #  ( $name, $mintip ) = std_tree_name_2( $node )
1669    #
1670    sub std_tree_name_2
1671    {
1672        my ( $node ) = @_;
1673    
1674        my @descends = newick_desc_list( $node );
1675        if ( @descends == 0 )
1676        {
1677            my $lbl = newick_lbl( $node );
1678            return ( $lbl, $lbl );
1679        }
1680    
1681        my @list = sort { lc $a->[1] cmp lc $b->[1] || $a->[1] cmp $b->[1] }
1682                   map  { [ std_tree_name_2( $_ ) ] }
1683                   @descends;
1684        my $mintip = $list[0]->[1];
1685        my $name   = '(' . join( "\t", map { $_->[0] } @list ) . ')';
1686    
1687        return ( $name, $mintip );
1688    }
1689    
1690    
1691    #-------------------------------------------------------------------------------
1692  #  Move largest groups to periphery of tree (in place).  #  Move largest groups to periphery of tree (in place).
1693  #  #
1694  #      dir  <= -2 for up-sweeping tree (big groups always first),  #      dir  <= -2 for up-sweeping tree (big groups always first),
# Line 1710  Line 1748 
1748      my $nd = newick_n_desc( $node );      my $nd = newick_n_desc( $node );
1749      if ( $nd <  1 ) { return $node }       #  Do nothing to a tip      if ( $nd <  1 ) { return $node }       #  Do nothing to a tip
1750    
     #  Reorder this subtree:  
   
1751      my $dl_ref = newick_desc_ref( $node );      my $dl_ref = newick_desc_ref( $node );
1752      if    ( $dir < 0 ) {                   #  Big group first  
1753          @$dl_ref = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;      #  Reorder this subtree (biggest subtrees to outside)
1754    
1755        if ( $dir )
1756        {
1757            #  Big group first
1758            my @dl = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
1759    
1760            my ( @dl1, @dl2 );
1761            for ( my $i = 0; $i < $nd; $i++ ) {
1762                if ( $i & 1 ) { push @dl2, $dl[$i] } else { push @dl1, $dl[$i] }
1763      }      }
1764      elsif ( $dir > 0 ) {                   #  Small group first  
1765          @$dl_ref = sort { $cntref->{$a} <=> $cntref->{$b} } @$dl_ref;          @$dl_ref = ( $dir < 0 ) ? ( @dl1, reverse @dl2 )
1766                                    : ( @dl2, reverse @dl1 );
1767      }      }
1768    
1769      #  Reorder within descendant subtrees:      #  Reorder within descendant subtrees:
# Line 2169  Line 2215 
2215  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2216  sub reroot_newick_to_approx_midpoint_w {  sub reroot_newick_to_approx_midpoint_w {
2217      my ( $tree ) = @_;      my ( $tree ) = @_;
2218        array_ref( $tree ) or return undef;
2219    
2220      #  Compile average tip to node distances assending from tips      #  Compile average tip to node distances assending from tips
2221    
# Line 2193  Line 2240 
2240  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2241  sub reroot_newick_to_midpoint_w {  sub reroot_newick_to_midpoint_w {
2242      my ( $tree ) = @_;      my ( $tree ) = @_;
2243        array_ref( $tree ) or return ();
2244    
2245      #  Compile average tip to node distances assending      #  Compile average tip to node distances assending
2246    
# Line 2208  Line 2256 
2256  }  }
2257    
2258    
2259    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2260  sub average_to_tips_1_w {  sub average_to_tips_1_w {
2261      my ( $node ) = @_;      my ( $node ) = @_;
2262    
# Line 2233  Line 2282 
2282  }  }
2283    
2284    
2285    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2286  sub average_to_tips_2_w {  sub average_to_tips_2_w {
2287      my ( $dists1, $x_above, $n_above, $anc_node ) = @_;      my ( $dists1, $x_above, $n_above, $anc_node ) = @_;
2288      my ( undef, $n_below, $x, $x_below, $desc_list, $node ) = @$dists1;      my ( undef, $n_below, $x, $x_below, $desc_list, $node ) = @$dists1;
# Line 3578  Line 3628 
3628      my @lines;      my @lines;
3629      foreach ( ( $y1 .. $y2 ) )      foreach ( ( $y1 .. $y2 ) )
3630      {      {
3631          my $line = text_tree_row( $node, $hash, $_, [], 'tee_l' );          my $line = text_tree_row( $node, $hash, $_, [], 'tee_l', $dy >= 2 );
3632          my $lbl  = '';          my $lbl  = '';
3633          if ( @$line )          if ( @$line )
3634          {          {
# Line 3675  Line 3725 
3725          $yn1 = $ylist[ 0];          $yn1 = $ylist[ 0];
3726          $yn2 = $ylist[-1];          $yn2 = $ylist[-1];
3727          $y = int( 0.5 * ( $yn1 + $yn2 ) + ( $yrnd || 0.4999 ) );          $y = int( 0.5 * ( $yn1 + $yn2 ) + ( $yrnd || 0.4999 ) );
3728    
3729            #  Handle special case of internal node label. Put it between subtrees.
3730    
3731            if ( ( $dy >= 2 ) && newick_lbl( $node ) && ( @dl > 1 ) ) {
3732                #  Find the descendents $i1 and $i2 to put the branch between
3733                my $i2 = 1;
3734                while ( ( $i2+1 < @ylist ) && ( $ylist[$i2] < $y ) ) { $i2++ }
3735                my $i1 = $i2 - 1;
3736                #  Get bottom of subtree1 and top of subtree2:
3737                my $ymax1 = $hash->{ $dl[ $i1 ] }->[ 1 ];
3738                my $ymin2 = $hash->{ $dl[ $i2 ] }->[ 0 ];
3739                #  Midway between bottom of subtree1 and top of subtree2, with
3740                #  preferred rounding direction
3741                $y = int( 0.5 * ( $ymax1 + $ymin2 ) + ( $yrnd || 0.4999 ) );
3742            }
3743      }      }
3744    
3745      $y2 = int( $ymax - 0.5 * $dy + 0.4999 );      $y2 = int( $ymax - 0.5 * $dy + 0.4999 );
# Line 3707  Line 3772 
3772  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3773  #  Produce a description of one line of a printer plot tree.  #  Produce a description of one line of a printer plot tree.
3774  #  #
3775  #  \@line = text_tree_row( $node, $hash, $row, \@line, $symb )  #  \@line = text_tree_row( $node, $hash, $row, \@line, $symb, $ilbl )
3776  #  #
3777  #     \@line is the character descriptions accumulated so far, one per array  #     \@line is the character descriptions accumulated so far, one per array
3778  #          element, except for a label, which can be any number of characters.  #          element, except for a label, which can be any number of characters.
# Line 3719  Line 3784 
3784  #     \%hash contains tree layout information  #     \%hash contains tree layout information
3785  #      $row  is the row number (y value) that we are building  #      $row  is the row number (y value) that we are building
3786  #      $symb is the plot symbol proposed for the current x and y position  #      $symb is the plot symbol proposed for the current x and y position
3787    #      $ilbl is true if internal node labels are allowed
3788  #  #
3789  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3790  sub text_tree_row  sub text_tree_row
3791  {  {
3792      my ( $node, $hash, $row, $line, $symb ) = @_;      my ( $node, $hash, $row, $line, $symb, $ilbl ) = @_;
3793    
3794      my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };      my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };
3795      if ( $row < $y1 || $row > $y2 ) { return $line }      if ( $row < $y1 || $row > $y2 ) { return $line }
# Line 3757  Line 3823 
3823          foreach ( @list ) {          foreach ( @list ) {
3824              my ( $n, $s ) = @$_;              my ( $n, $s ) = @$_;
3825              if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {              if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {
3826                  $line = text_tree_row( $n, $hash, $row, $line, $s );                  $line = text_tree_row( $n, $hash, $row, $line, $s, $ilbl );
3827              }              }
3828           }           }
3829    
3830          if ( $row == $y ) {          if ( $row == $y ) {
3831              $line->[$x] = ( $line->[$x] eq 'horiz' ) ? 'tee_l'              $line->[$x] = ( $line->[$x] eq 'horiz' ) ? 'tee_l'
3832                                                       : $with_left_line{ $line->[$x] };                                                       : $with_left_line{ $line->[$x] };
3833                push( @$line, newick_lbl( $node ), '' ) if $ilbl && newick_lbl( $node );
3834          }          }
3835      }      }
3836    
# Line 3808  Line 3875 
3875  {  {
3876      my $file = shift;      my $file = shift;
3877      my $fh;      my $fh;
3878      if    ( ! defined( $file ) )     { return ( \*STDIN ) }      if    ( ! defined $file || $file eq '' ) { return ( \*STDIN ) }
3879      elsif ( ref( $file ) eq 'GLOB' ) { return ( $file   ) }      elsif ( ref( $file ) eq 'GLOB' ) { return ( $file   ) }
3880      elsif ( open( $fh, "<$file" ) )  { return ( $fh, 1  ) } # Need to close      elsif ( open( $fh, "<$file" ) )  { return ( $fh, 1  ) } # Need to close
3881    
# Line 3829  Line 3896 
3896  {  {
3897      my $file = shift;      my $file = shift;
3898      my $fh;      my $fh;
3899      if    ( ! defined( $file ) )     { return ( \*STDOUT ) }      if    ( ! defined $file || $file eq '' ) { return ( \*STDOUT ) }
3900      elsif ( ref( $file ) eq 'GLOB' ) { return ( $file    ) }      elsif ( ref( $file ) eq 'GLOB' ) { return ( $file    ) }
3901      elsif ( ( open $fh, ">$file" ) ) { return ( $fh, 1   ) } # Need to close      elsif ( ( open $fh, ">$file" ) ) { return ( $fh, 1   ) } # Need to close
3902    

Legend:
Removed from v.1.15  
changed lines
  Added in v.1.21

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3