[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.19, Tue Apr 13 20:33:16 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-2007 University of Chicago and Fellowship
5  # for Interpretations of Genomes. All Rights Reserved.  # for Interpretations of Genomes. All Rights Reserved.
# Line 1710  Line 1712 
1712      my $nd = newick_n_desc( $node );      my $nd = newick_n_desc( $node );
1713      if ( $nd <  1 ) { return $node }       #  Do nothing to a tip      if ( $nd <  1 ) { return $node }       #  Do nothing to a tip
1714    
     #  Reorder this subtree:  
   
1715      my $dl_ref = newick_desc_ref( $node );      my $dl_ref = newick_desc_ref( $node );
1716      if    ( $dir < 0 ) {                   #  Big group first  
1717          @$dl_ref = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;      #  Reorder this subtree (biggest subtrees to outside)
1718    
1719        if ( $dir )
1720        {
1721            #  Big group first
1722            my @dl = sort { $cntref->{$b} <=> $cntref->{$a} } @$dl_ref;
1723    
1724            my ( @dl1, @dl2 );
1725            for ( my $i = 0; $i < $nd; $i++ ) {
1726                if ( $i & 1 ) { push @dl2, $dl[$i] } else { push @dl1, $dl[$i] }
1727      }      }
1728      elsif ( $dir > 0 ) {                   #  Small group first  
1729          @$dl_ref = sort { $cntref->{$a} <=> $cntref->{$b} } @$dl_ref;          @$dl_ref = ( $dir < 0 ) ? ( @dl1, reverse @dl2 )
1730                                    : ( @dl2, reverse @dl1 );
1731      }      }
1732    
1733      #  Reorder within descendant subtrees:      #  Reorder within descendant subtrees:
# Line 3578  Line 3588 
3588      my @lines;      my @lines;
3589      foreach ( ( $y1 .. $y2 ) )      foreach ( ( $y1 .. $y2 ) )
3590      {      {
3591          my $line = text_tree_row( $node, $hash, $_, [], 'tee_l' );          my $line = text_tree_row( $node, $hash, $_, [], 'tee_l', $dy >= 2 );
3592          my $lbl  = '';          my $lbl  = '';
3593          if ( @$line )          if ( @$line )
3594          {          {
# Line 3675  Line 3685 
3685          $yn1 = $ylist[ 0];          $yn1 = $ylist[ 0];
3686          $yn2 = $ylist[-1];          $yn2 = $ylist[-1];
3687          $y = int( 0.5 * ( $yn1 + $yn2 ) + ( $yrnd || 0.4999 ) );          $y = int( 0.5 * ( $yn1 + $yn2 ) + ( $yrnd || 0.4999 ) );
3688    
3689            #  Handle special case of internal node label. Put it between subtrees.
3690    
3691            if ( ( $dy >= 2 ) && newick_lbl( $node ) && ( @dl > 1 ) ) {
3692                #  Find the descendents $i1 and $i2 to put the branch between
3693                my $i2 = 1;
3694                while ( ( $i2+1 < @ylist ) && ( $ylist[$i2] < $y ) ) { $i2++ }
3695                my $i1 = $i2 - 1;
3696                #  Get bottom of subtree1 and top of subtree2:
3697                my $ymax1 = $hash->{ $dl[ $i1 ] }->[ 1 ];
3698                my $ymin2 = $hash->{ $dl[ $i2 ] }->[ 0 ];
3699                #  Midway between bottom of subtree1 and top of subtree2, with
3700                #  preferred rounding direction
3701                $y = int( 0.5 * ( $ymax1 + $ymin2 ) + ( $yrnd || 0.4999 ) );
3702            }
3703      }      }
3704    
3705      $y2 = int( $ymax - 0.5 * $dy + 0.4999 );      $y2 = int( $ymax - 0.5 * $dy + 0.4999 );
# Line 3707  Line 3732 
3732  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3733  #  Produce a description of one line of a printer plot tree.  #  Produce a description of one line of a printer plot tree.
3734  #  #
3735  #  \@line = text_tree_row( $node, $hash, $row, \@line, $symb )  #  \@line = text_tree_row( $node, $hash, $row, \@line, $symb, $ilbl )
3736  #  #
3737  #     \@line is the character descriptions accumulated so far, one per array  #     \@line is the character descriptions accumulated so far, one per array
3738  #          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 3744 
3744  #     \%hash contains tree layout information  #     \%hash contains tree layout information
3745  #      $row  is the row number (y value) that we are building  #      $row  is the row number (y value) that we are building
3746  #      $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
3747    #      $ilbl is true if internal node labels are allowed
3748  #  #
3749  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3750  sub text_tree_row  sub text_tree_row
3751  {  {
3752      my ( $node, $hash, $row, $line, $symb ) = @_;      my ( $node, $hash, $row, $line, $symb, $ilbl ) = @_;
3753    
3754      my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };      my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };
3755      if ( $row < $y1 || $row > $y2 ) { return $line }      if ( $row < $y1 || $row > $y2 ) { return $line }
# Line 3757  Line 3783 
3783          foreach ( @list ) {          foreach ( @list ) {
3784              my ( $n, $s ) = @$_;              my ( $n, $s ) = @$_;
3785              if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {              if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {
3786                  $line = text_tree_row( $n, $hash, $row, $line, $s );                  $line = text_tree_row( $n, $hash, $row, $line, $s, $ilbl );
3787              }              }
3788           }           }
3789    
3790          if ( $row == $y ) {          if ( $row == $y ) {
3791              $line->[$x] = ( $line->[$x] eq 'horiz' ) ? 'tee_l'              $line->[$x] = ( $line->[$x] eq 'horiz' ) ? 'tee_l'
3792                                                       : $with_left_line{ $line->[$x] };                                                       : $with_left_line{ $line->[$x] };
3793                push( @$line, newick_lbl( $node ), '' ) if $ilbl && newick_lbl( $node );
3794          }          }
3795      }      }
3796    

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3