[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.12, Mon Jun 22 19:14:50 2009 UTC revision 1.15, Sun Sep 6 22:38:32 2009 UTC
# Line 203  Line 203 
203  #  $n_changed = newick_set_all_branches( $node, $x )  #  $n_changed = newick_set_all_branches( $node, $x )
204  #  $n_changed = newick_fix_negative_branches( $tree )  #  $n_changed = newick_fix_negative_branches( $tree )
205  #  $node      = newick_rescale_branches( $node, $factor )  #  $node      = newick_rescale_branches( $node, $factor )
206    #  $node      = newick_modify_branches( $node, \&function )
207    #  $node      = newick_modify_branches( $node, \&function, \@func_parms )
208  #  #
209  #  Modify comments:  #  Modify comments:
210  #  #
# Line 345  Line 347 
347          newick_set_all_branches          newick_set_all_branches
348          newick_fix_negative_branches          newick_fix_negative_branches
349          newick_rescale_branches          newick_rescale_branches
350            newick_modify_branches
351    
352          newick_strip_comments          newick_strip_comments
353    
# Line 1535  Line 1538 
1538    
1539    
1540  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1541    #  Modify all branch lengths by a function.
1542    #
1543    #     $node = newick_modify_branches( $node, \&function )
1544    #     $node = newick_modify_branches( $node, \&function, \@func_parms )
1545    #
1546    #  Function must have form
1547    #
1548    #     $x2 = &$function( $x1 )
1549    #     $x2 = &$function( $x1, @$func_parms )
1550    #
1551    #-------------------------------------------------------------------------------
1552    sub newick_modify_branches {
1553        my ( $node, $func, $parm ) = @_;
1554    
1555        set_newick_x( $node, &$func( newick_x( $node ), ( $parm ? @$parm : () ) ) );
1556        foreach ( newick_desc_list( $node ) )
1557        {
1558            newick_modify_branches( $_, $func, $parm )
1559        }
1560    
1561        $node;
1562    }
1563    
1564    
1565    #-------------------------------------------------------------------------------
1566  #  Set negative branches to zero.  The original tree is modfied.  #  Set negative branches to zero.  The original tree is modfied.
1567  #  #
1568  #  $n_changed = newick_fix_negative_branches( $tree )  #  $n_changed = newick_fix_negative_branches( $tree )
# Line 1972  Line 2000 
2000      #  Trim the common prefix, saving it:      #  Trim the common prefix, saving it:
2001    
2002      my @prefix = ();      my @prefix = ();
2003      while ( $path1[1] == $path2[1] )      while ( defined( $path1[1] ) && defined( $path2[1] ) && ( $path1[1] == $path2[1] ) )
2004      {      {
2005          push @prefix, splice( @path1, 0, 2 );          push @prefix, splice( @path1, 0, 2 );
2006          splice( @path2, 0, 2 );          splice( @path2, 0, 2 );
# Line 3325  Line 3353 
3353  #===============================================================================  #===============================================================================
3354  #  Make a printer plot of a tree:  #  Make a printer plot of a tree:
3355  #  #
3356  #     $node   newick tree root node  #  printer_plot_newick( $node, $file, $width, $min_dx, $dy )
3357  #     $file   undef (= \*STDOUT), \*STDOUT, \*STDERR, or a file name.  #  printer_plot_newick( $node, $file, \%options )
3358  #     $width  the approximate characters for the tree without labels  #
3359  #     $min_dx the minimum horizontal branch length  #     $node   # newick tree root node
3360  #     $dy     the vertical space per taxon  #     $file   # undef = \*STDOUT, \*FH, or a file name.
3361    #     $width  # the approximate characters for the tree without labels (D = 68)
3362    #     $min_dx # the minimum horizontal branch length (D = 2)
3363    #     $dy     # the vertical space per taxon (D = 1, most compressed)
3364    #
3365    #  Options:
3366    #
3367    #    dy     => nat_number    # the vertical space per taxon
3368    #    chars  => key           # line drawing character set:
3369    #                            #     html_unicode
3370    #                            #     text (default)
3371    #    min_dx => whole_number  # the minimum horizontal branch length
3372    #    width  => whole_number  # approximate tree width without labels
3373  #  #
 #  printer_plot_newick( $node, $file (D=\*STDOUT), $width (D=68), $min_dx (D=2), $dy (D=1) )  
3374  #===============================================================================  #===============================================================================
3375  sub printer_plot_newick {  sub printer_plot_newick
3376      my ( $node, $file, $width, $min_dx, $dy ) = @_;  {
3377        my ( $node, $file, @opts ) = @_;
3378    
3379      my ( $fh, $close ) = open_output( $file );      my ( $fh, $close ) = open_output( $file );
3380      $fh or return;      $fh or return;
3381    
3382      print $fh join( "\n", text_plot_newick( $node, $width, $min_dx, $dy ) ), "\n";      my $html = $opts[0] && ref($opts[0]) eq 'HASH'
3383                            && $opts[0]->{ chars }
3384                            && $opts[0]->{ chars } =~ /html/;
3385        print $fh '<PRE>' if $html;
3386        print $fh join( "\n", text_plot_newick( $node, @opts ) ), "\n";
3387        print $fh "</PRE>\n" if $html;
3388    
3389      if ( $close ) { close $fh }      if ( $close ) { close $fh }
3390  }  }
3391    
3392    
3393  #===============================================================================  #===============================================================================
3394    #  Character sets for printer plot trees:
3395    #-------------------------------------------------------------------------------
3396    
3397    my %char_set =
3398      ( text1     => { space  => ' ',
3399                       horiz  => '-',
3400                       vert   => '|',
3401                       el_d_r => '/',
3402                       el_u_r => '\\',
3403                       el_d_l => '\\',
3404                       el_u_l => '/',
3405                       tee_l  => '+',
3406                       tee_r  => '+',
3407                       tee_u  => '+',
3408                       tee_d  => '+',
3409                       half_l => '-',
3410                       half_r => '-',
3411                       half_u => '|',
3412                       half_d => '|',
3413                       cross  => '+',
3414                     },
3415        text2     => { space  => ' ',
3416                       horiz  => '-',
3417                       vert   => '|',
3418                       el_d_r => '+',
3419                       el_u_r => '+',
3420                       el_d_l => '+',
3421                       el_u_l => '+',
3422                       tee_l  => '+',
3423                       tee_r  => '+',
3424                       tee_u  => '+',
3425                       tee_d  => '+',
3426                       half_l => '-',
3427                       half_r => '-',
3428                       half_u => '|',
3429                       half_d => '|',
3430                       cross  => '+',
3431                     },
3432        html_box  => { space  => '&nbsp;',
3433                       horiz  => '&#9472;',
3434                       vert   => '&#9474;',
3435                       el_d_r => '&#9484;',
3436                       el_u_r => '&#9492;',
3437                       el_d_l => '&#9488;',
3438                       el_u_l => '&#9496;',
3439                       tee_l  => '&#9508;',
3440                       tee_r  => '&#9500;',
3441                       tee_u  => '&#9524;',
3442                       tee_d  => '&#9516;',
3443                       half_l => '&#9588;',
3444                       half_r => '&#9590;',
3445                       half_u => '&#9589;',
3446                       half_d => '&#9591;',
3447                       cross  => '&#9532;',
3448                     },
3449        utf8_box  => { space  => ' ',
3450                       horiz  => chr(226) . chr(148) . chr(128),
3451                       vert   => chr(226) . chr(148) . chr(130),
3452                       el_d_r => chr(226) . chr(148) . chr(140),
3453                       el_u_r => chr(226) . chr(148) . chr(148),
3454                       el_d_l => chr(226) . chr(148) . chr(144),
3455                       el_u_l => chr(226) . chr(148) . chr(152),
3456                       tee_l  => chr(226) . chr(148) . chr(164),
3457                       tee_r  => chr(226) . chr(148) . chr(156),
3458                       tee_u  => chr(226) . chr(148) . chr(180),
3459                       tee_d  => chr(226) . chr(148) . chr(172),
3460                       half_l => chr(226) . chr(149) . chr(180),
3461                       half_r => chr(226) . chr(149) . chr(182),
3462                       half_u => chr(226) . chr(149) . chr(181),
3463                       half_d => chr(226) . chr(149) . chr(183),
3464                       cross  => chr(226) . chr(148) . chr(188),
3465                     },
3466      );
3467    
3468    %{ $char_set{ html1 } } = %{ $char_set{ text1 } };
3469    $char_set{ html1 }->{ space } = '&nbsp;';
3470    
3471    %{ $char_set{ html2 } } = %{ $char_set{ text2 } };
3472    $char_set{ html2 }->{ space } = '&nbsp;';
3473    
3474    #  Define some synonyms
3475    
3476    $char_set{ html } = $char_set{ html_box };
3477    $char_set{ line } = $char_set{ utf8_box };
3478    $char_set{ symb } = $char_set{ utf8_box };
3479    $char_set{ text } = $char_set{ text1 };
3480    $char_set{ utf8 } = $char_set{ utf8_box };
3481    
3482    #  Define tree formats and synonyms
3483    
3484    my %tree_format =
3485        ( text         => 'text',
3486          tree_tab_lbl => 'tree_tab_lbl',
3487          tree_lbl     => 'tree_lbl',
3488          chrlist_lbl  => 'chrlist_lbl',
3489          raw          => 'chrlist_lbl',
3490        );
3491    
3492    #===============================================================================
3493  #  Make a text plot of a tree:  #  Make a text plot of a tree:
3494  #  #
3495  #     $node   newick tree root node  #  @lines = text_plot_newick( $node, $width, $min_dx, $dy )
3496  #     $width  the approximate characters for the tree without labels  #  @lines = text_plot_newick( $node, \%options )
3497  #     $min_dx the minimum horizontal branch length  #
3498  #     $dy     the vertical space per taxon  #     $node   # newick tree root node
3499    #     $width  # the approximate characters for the tree without labels (D = 68)
3500    #     $min_dx # the minimum horizontal branch length (D = 2)
3501    #     $dy     # the vertical space per taxon (D = 1, most compressed)
3502    #
3503    #  Options:
3504    #
3505    #    chars  => keyword       # the output character set for the tree
3506    #    dy     => nat_number    # the vertical space per taxon
3507    #    format => keyword       # output format of each line
3508    #    min_dx => whole_number  # the minimum horizontal branch length
3509    #    width  => whole_number  # approximate tree width without labels
3510    #
3511    #  Character sets:
3512    #
3513    #    html       #  synonym of html1
3514    #    html_box   #  html encoding of unicode box drawing characters
3515    #    html1      #  text1 with nonbreaking spaces
3516    #    html2      #  text2 with nonbreaking spaces
3517    #    line       #  synonym of utf8_box
3518    #    raw        #  pass out the internal representation
3519    #    symb       #  synonym of utf8_box
3520    #    text       #  synonym of text1 (Default)
3521    #    text1      #  ascii characters: - + | / \ and space
3522    #    text2      #  ascii characters: - + | + + and space
3523    #    utf8       #  synonym of utf8_box
3524    #    utf8_box   #  utf8 encoding of unicode box drawing characters
3525    #
3526    #  Formats for row lines:
3527    #
3528    #    text           #    $textstring              # Default
3529    #    tree_tab_lbl   #    $treestr \t $labelstr
3530    #    tree_lbl       # [  $treestr,  $labelstr ]
3531    #    chrlist_lbl    # [ \@treechar, $labelstr ]   # Forced with raw chars
3532    #    raw            #  synonym of chrlist_lbl
3533  #  #
 #  @textlines = text_plot_newick( $node, $width (D=68), $min_dx (D=2), $dy (D=1) )  
3534  #===============================================================================  #===============================================================================
3535  sub text_plot_newick {  sub text_plot_newick
3536      my ( $node, $width, $min_dx, $dy ) = @_;  {
3537        my $node = shift @_;
3538      array_ref( $node ) || die "Bad node passed to text_plot_newick\n";      array_ref( $node ) || die "Bad node passed to text_plot_newick\n";
3539      defined( $min_dx ) and ( $min_dx >=  0 ) or $min_dx =  2;  
3540      defined(     $dy ) and (     $dy >=  1 ) or     $dy =  1;      my ( $opts, $width, $min_dx, $dy, $chars, $fmt );
3541      defined( $width  )                       or  $width = 68;      if ( $_[0] && ref $_[0] eq 'HASH' )
3542        {
3543            $opts = shift;
3544        }
3545        else
3546        {
3547            ( $width, $min_dx, $dy ) = @_;
3548            $opts = {};
3549        }
3550    
3551        $chars = $opts->{ chars } || '';
3552        my $charH;
3553        $charH = $char_set{ $chars } || $char_set{ 'text1' } if ( $chars ne 'raw' );
3554        my $is_box = $charH eq $char_set{ html_box }
3555                  || $charH eq $char_set{ utf8_box }
3556                  || $chars eq 'raw';
3557    
3558        $fmt = ( $chars eq 'raw' ) ? 'chrlist_lbl' : $opts->{ format };
3559        $fmt = $tree_format{ $fmt || '' } || 'text';
3560    
3561        $dy    ||= $opts->{ dy     } ||  1;
3562        $width ||= $opts->{ width  } || 68;
3563        $min_dx  = $opts->{ min_dx } if ( ! defined $min_dx || $min_dx < 0 );
3564        $min_dx  = $is_box ? 1 : 2   if ( ! defined $min_dx || $min_dx < 0 );
3565    
3566        #  Layout the tree:
3567    
3568      $min_dx = int( $min_dx );      $min_dx = int( $min_dx );
3569      $dy     = int( $dy );      $dy     = int( $dy );
# Line 3368  Line 3572 
3572      my $hash = {};      my $hash = {};
3573      layout_printer_plot( $node, $hash, 0, -0.5 * $dy, $x_scale, $min_dx, $dy );      layout_printer_plot( $node, $hash, 0, -0.5 * $dy, $x_scale, $min_dx, $dy );
3574    
3575      # dump_tree_hash( $node, $hash ); exit;      #  Generate the lines of the tree-one by-one:
   
     #  Generate the lines of the tree one by one:  
3576    
3577      my ( $y1, $y2 ) = @{ $hash->{ $node } };      my ( $y1, $y2 ) = @{ $hash->{ $node } };
3578      map { text_tree_row( $node, $hash, $_, "", "+" ) } ( $y1 .. $y2 );      my @lines;
3579        foreach ( ( $y1 .. $y2 ) )
3580        {
3581            my $line = text_tree_row( $node, $hash, $_, [], 'tee_l' );
3582            my $lbl  = '';
3583            if ( @$line )
3584            {
3585                if ( $line->[-1] eq '' ) { pop @$line; $lbl = pop @$line }
3586                #  Translate tree characters
3587                @$line = map { $charH->{ $_ } } @$line if $chars ne 'raw';
3588            }
3589    
3590            # Convert to requested output format:
3591    
3592            push @lines, $fmt eq 'text'         ? join( '', @$line, ( $lbl ? " $lbl" : () ) )
3593                       : $fmt eq 'text_tab_lbl' ? join( '', @$line, "\t", $lbl )
3594                       : $fmt eq 'tree_lbl'     ? [ join( '', @$line ), $lbl ]
3595                       : $fmt eq 'chrlist_lbl'  ? [ $line, $lbl ]
3596                       :                          ();
3597        }
3598    
3599        # if ( $cells )
3600        # {
3601        #     my $nmax = 0;
3602        #     foreach ( @lines ) { $nmax = @$_ if @$_ > $nmax }
3603        #     foreach ( @lines )
3604        #     {
3605        #         @$_ = map { "<TD>$_</TD>" } @$_;
3606        #         my $span = $nmax - @$_ + 1;
3607        #         $_->[-1] =~ s/^<TD>/<TD NoWrap ColSpan=$span>/;
3608        #     }
3609        # }
3610        # elsif ( $tables )
3611        # {
3612        #     my $nmax = 0;
3613        #     foreach ( @lines ) { $nmax = @$_ if @$_ > $nmax }
3614        #     foreach ( @lines )
3615        #     {
3616        #         @$_ = map { "<TD>$_</TD>" } @$_;
3617        #         my $span = $nmax - @$_ + 1;
3618        #         $_->[-1] =~ s/^<TD>/<TD NoWrap ColSpan=$span>/;
3619        #     }
3620        # }
3621    
3622        wantarray ? @lines : \@lines;
3623  }  }
3624    
3625    
3626  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3627  #  ( $xmax, $ymax, $root_y ) = layout_printer_plot( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy )  #  ( $xmax, $ymax, $root_y ) = layout_printer_plot( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy, $yrnd )
3628  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3629  sub layout_printer_plot {  sub layout_printer_plot
3630      my ( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy ) = @_;  {
3631        my ( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy, $yrnd ) = @_;
3632      array_ref( $node ) || die "Bad node ref passed to layout_printer_plot\n";      array_ref( $node ) || die "Bad node ref passed to layout_printer_plot\n";
3633      hash_ref(  $hash ) || die "Bad hash ref passed to layout_printer_plot\n";      hash_ref(  $hash ) || die "Bad hash ref passed to layout_printer_plot\n";
3634    
3635      my $dx = newick_x( $node );      my $dx = newick_x( $node );
3636      if ( defined( $dx ) ) {      if ( defined( $dx ) ) {
3637          $dx *= $x_scale;          $dx *= $x_scale;
3638          $dx >= $min_dx or $dx = $min_dx;          $dx = $min_dx if $dx < $min_dx;
3639      }      }
3640      else {      else {
3641          $dx = ( $x0 > 0 ) ? $min_dx : 0;          $dx = ( $x0 > 0 ) ? $min_dx : 0;
# Line 3414  Line 3662 
3662          $ymax = $y0;          $ymax = $y0;
3663    
3664          foreach ( @dl ) {          foreach ( @dl ) {
3665              ( $xmaxi, $ymax, $yi ) = layout_printer_plot( $_, $hash, $x, $ymax, $x_scale, $min_dx, $dy );              ( $xmaxi, $ymax, $yi ) = layout_printer_plot( $_, $hash, $x, $ymax, $x_scale, $min_dx, $dy,
3666                                                              ( 2*@ylist < @dl ? 0.5001 : 0.4999 )
3667                                                            );
3668              push @ylist, $yi;              push @ylist, $yi;
3669              if ( $xmaxi > $xmax ) { $xmax = $xmaxi }              if ( $xmaxi > $xmax ) { $xmax = $xmaxi }
3670          }          }
# Line 3424  Line 3674 
3674    
3675          $yn1 = $ylist[ 0];          $yn1 = $ylist[ 0];
3676          $yn2 = $ylist[-1];          $yn2 = $ylist[-1];
3677          $y = int( 0.5 * ( $yn1 + $yn2 ) + 0.4999 );          $y = int( 0.5 * ( $yn1 + $yn2 ) + ( $yrnd || 0.4999 ) );
3678      }      }
3679    
3680      $y2 = int( $ymax - 0.5 * $dy + 0.4999 );      $y2 = int( $ymax - 0.5 * $dy + 0.4999 );
# Line 3434  Line 3684 
3684  }  }
3685    
3686    
3687  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #  What symbol do we get if we add a leftward line to some other symbol?
 #  Debug routine  
 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  
 sub dump_tree {  
     my ( $node, $prefix ) = @_;  
     defined( $prefix ) or $prefix = "";  
     print STDERR $prefix, join(", ", @$node), "\n";  
     my @dl = $node->[0] ? @{$node->[0]} : ();  
     foreach ( @dl ) { dump_tree( $_, $prefix . "  " ) }  
     $prefix or print STDERR "\n";  
 }  
   
   
 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  
 #  Debug routine  
 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  
 sub dump_tree_hash {  
     my ( $node, $hash, $prefix ) = @_;  
     defined( $prefix ) or print STDERR "node; [ y1, y2, x0, x, y, yn1, yn2 ]\n" and $prefix = "";  
     print STDERR $prefix, join(", ", @$node), "; ", join(", ", @{ $hash->{ $node } } ), "\n";  
     my @dl = $node->[0] ? @{$node->[0]} : ();  
     foreach (@dl) { dump_tree_hash( $_, $hash, $prefix . "  " ) }  
 }  
3688    
3689    my %with_left_line = ( space  => 'half_l',
3690                           horiz  => 'horiz',
3691                           vert   => 'tee_l',
3692                           el_d_r => 'tee_d',
3693                           el_u_r => 'tee_u',
3694                           el_d_l => 'el_d_l',
3695                           el_u_l => 'el_u_l',
3696                           tee_l  => 'tee_l',
3697                           tee_r  => 'cross',
3698                           tee_u  => 'tee_u',
3699                           tee_d  => 'tee_d',
3700                           half_l => 'half_l',
3701                           half_r => 'horiz',
3702                           half_u => 'el_u_l',
3703                           half_d => 'el_d_l',
3704                           cross  => 'cross',
3705                         );
3706    
3707  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3708  #  $line = text_tree_row( $node, $hash, $row, $line, $symb )  #  Produce a description of one line of a printer plot tree.
3709    #
3710    #  \@line = text_tree_row( $node, $hash, $row, \@line, $symb )
3711    #
3712    #     \@line is the character descriptions accumulated so far, one per array
3713    #          element, except for a label, which can be any number of characters.
3714    #          Labels are followed by an empty string, so if $line->[-1] eq '',
3715    #          then $line->[-2] is a label. The calling program translates the
3716    #          symbol names to output characters.
3717    #
3718    #     \@node is a newick tree node
3719    #     \%hash contains tree layout information
3720    #      $row  is the row number (y value) that we are building
3721    #      $symb is the plot symbol proposed for the current x and y position
3722    #
3723  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3724  sub text_tree_row {  sub text_tree_row
3725    {
3726      my ( $node, $hash, $row, $line, $symb ) = @_;      my ( $node, $hash, $row, $line, $symb ) = @_;
3727    
3728      my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };      my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };
3729      if ( $row < $y1 || $row > $y2 ) { return $line }      if ( $row < $y1 || $row > $y2 ) { return $line }
3730    
3731      if ( length( $line ) < $x0 ) { $line .= " " x ( $x0 - length( $line ) ) }      if ( @$line < $x0 ) { push @$line, ('space') x ( $x0 - @$line ) }
3732    
3733      if ( $row == $y ) {      if ( $row == $y ) {
3734          $line = substr( $line, 0, $x0 ) . $symb . (( $x > $x0 ) ? "-" x ($x - $x0) : "");          while ( @$line > $x0 ) { pop @$line }  # Actually 0-1 times
3735            push @$line, $symb,
3736                         ( ( $x > $x0 ) ? ('horiz') x ($x - $x0) : () );
3737      }      }
3738    
3739      elsif ( $row > $yn1 && $row < $yn2 ) {      elsif ( $row > $yn1 && $row < $yn2 ) {
3740          if ( length( $line ) < $x ) { $line .= " " x ( $x - length( $line ) ) . "|" }          if ( @$line < $x ) { push @$line, ('space') x ( $x - @$line ), 'vert' }
3741          else { substr( $line, $x ) = "|" }          else               { $line->[$x] = 'vert' }
3742      }      }
3743    
3744      my @dl = newick_desc_list( $node );      my @dl = newick_desc_list( $node );
3745    
3746      if ( @dl < 1 ) {      if ( @dl < 1 ) { push @$line, ( newick_lbl( $node ) || '' ), '' }
         $line .= " " . $node->[1];  
     }  
3747    
3748      else {      else {
3749          my @list = map { [ $_, "+" ] } @dl;  #  Print symbol for line          my @list = map { [ $_, 'tee_r' ] } @dl;  # Line to the right
3750          $list[ 0]->[1] = "/";          if ( @list > 1 ) { #  Fix top and bottom sympbols
3751          $list[-1]->[1] = "\\";              $list[ 0]->[1] = 'el_d_r';
3752                $list[-1]->[1] = 'el_u_r';
3753            }
3754            elsif ( @list ) {  # Only one descendent
3755                $list[ 0]->[1] = 'half_r';
3756            }
3757          foreach ( @list ) {          foreach ( @list ) {
3758              my ( $n, $s ) = @$_;              my ( $n, $s ) = @$_;
3759              if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {              if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {
# Line 3497  Line 3761 
3761              }              }
3762           }           }
3763    
3764          if ( $row == $y ) { substr( $line, $x, 1 ) = "+" }          if ( $row == $y ) {
3765                $line->[$x] = ( $line->[$x] eq 'horiz' ) ? 'tee_l'
3766                                                         : $with_left_line{ $line->[$x] };
3767            }
3768      }      }
3769    
3770      return $line;      return $line;
3771  }  }
3772    
3773    
3774    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3775    #  Debug routine
3776    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3777    sub dump_tree {
3778        my ( $node, $prefix ) = @_;
3779        defined( $prefix ) or $prefix = "";
3780        print STDERR $prefix, join(", ", @$node), "\n";
3781        my @dl = $node->[0] ? @{$node->[0]} : ();
3782        foreach ( @dl ) { dump_tree( $_, $prefix . "  " ) }
3783        $prefix or print STDERR "\n";
3784    }
3785    
3786    
3787    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3788    #  Debug routine
3789    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3790    sub dump_tree_hash {
3791        my ( $node, $hash, $prefix ) = @_;
3792        defined( $prefix ) or print STDERR "node; [ y1, y2, x0, x, y, yn1, yn2 ]\n" and $prefix = "";
3793        print STDERR $prefix, join(", ", @$node), "; ", join(", ", @{ $hash->{ $node } } ), "\n";
3794        my @dl = $node->[0] ? @{$node->[0]} : ();
3795        foreach (@dl) { dump_tree_hash( $_, $hash, $prefix . "  " ) }
3796    }
3797    
3798    
3799  #===============================================================================  #===============================================================================
3800  #  Open an input file stream:  #  Open an input file stream:
3801  #  #

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3