[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.13, Wed Jul 1 00:08:52 2009 UTC
# Line 3325  Line 3325 
3325  #===============================================================================  #===============================================================================
3326  #  Make a printer plot of a tree:  #  Make a printer plot of a tree:
3327  #  #
3328  #     $node   newick tree root node  #  printer_plot_newick( $node, $file, $width, $min_dx, $dy )
3329  #     $file   undef (= \*STDOUT), \*STDOUT, \*STDERR, or a file name.  #  printer_plot_newick( $node, $file, \%options )
3330  #     $width  the approximate characters for the tree without labels  #
3331  #     $min_dx the minimum horizontal branch length  #     $node   # newick tree root node
3332  #     $dy     the vertical space per taxon  #     $file   # undef = \*STDOUT, \*FH, or a file name.
3333    #     $width  # the approximate characters for the tree without labels (D = 68)
3334    #     $min_dx # the minimum horizontal branch length (D = 2)
3335    #     $dy     # the vertical space per taxon (D = 1, most compressed)
3336    #
3337    #  Options:
3338    #
3339    #    dy     => nat_number    # the vertical space per taxon
3340    #    chars  => key           # line drawing character set:
3341    #                            #     html_unicode
3342    #                            #     text (default)
3343    #    min_dx => whole_number  # the minimum horizontal branch length
3344    #    width  => whole_number  # approximate tree width without labels
3345  #  #
 #  printer_plot_newick( $node, $file (D=\*STDOUT), $width (D=68), $min_dx (D=2), $dy (D=1) )  
3346  #===============================================================================  #===============================================================================
3347  sub printer_plot_newick {  sub printer_plot_newick
3348      my ( $node, $file, $width, $min_dx, $dy ) = @_;  {
3349        my ( $node, $file, @opts ) = @_;
3350    
3351      my ( $fh, $close ) = open_output( $file );      my ( $fh, $close ) = open_output( $file );
3352      $fh or return;      $fh or return;
3353    
3354      print $fh join( "\n", text_plot_newick( $node, $width, $min_dx, $dy ) ), "\n";      my $html = $opts[0] && ref($opts[0]) eq 'HASH'
3355                            && $opts[0]->{ chars }
3356                            && $opts[0]->{ chars } =~ /html/;
3357        print $fh '<PRE>' if $html;
3358        print $fh join( "\n", text_plot_newick( $node, @opts ) ), "\n";
3359        print $fh "</PRE>\n" if $html;
3360    
3361      if ( $close ) { close $fh }      if ( $close ) { close $fh }
3362  }  }
3363    
3364    
3365    #-------------------------------------------------------------------------------
3366    #  Character sets for tree:
3367    #-------------------------------------------------------------------------------
3368    my $default_chars = 'text1';
3369    my %char_set =
3370      ( text1     => { space  => ' ',
3371                       horiz  => '-',
3372                       vert   => '|',
3373                       el_d_r => '/',
3374                       el_u_r => '\\',
3375                       el_d_l => '\\',
3376                       el_u_l => '/',
3377                       tee_l  => '+',
3378                       tee_r  => '+',
3379                       tee_u  => '+',
3380                       tee_d  => '+',
3381                       half_l => '-',
3382                       half_r => '-',
3383                       half_u => '|',
3384                       half_d => '|',
3385                       cross  => '+',
3386                     },
3387        html1     => { space  => '&nbsp;',
3388                       horiz  => '-',
3389                       vert   => '|',
3390                       el_d_r => '/',
3391                       el_u_r => '\\',
3392                       el_d_l => '\\',
3393                       el_u_l => '/',
3394                       tee_l  => '+',
3395                       tee_r  => '+',
3396                       tee_u  => '+',
3397                       tee_d  => '+',
3398                       half_l => '-',
3399                       half_r => '-',
3400                       half_u => '|',
3401                       half_d => '|',
3402                       cross  => '+',
3403                     },
3404        text2     => { space  => ' ',
3405                       horiz  => '-',
3406                       vert   => '|',
3407                       el_d_r => '+',
3408                       el_u_r => '+',
3409                       el_d_l => '+',
3410                       el_u_l => '+',
3411                       tee_l  => '+',
3412                       tee_r  => '+',
3413                       tee_u  => '+',
3414                       tee_d  => '+',
3415                       half_l => '-',
3416                       half_r => '-',
3417                       half_u => '|',
3418                       half_d => '|',
3419                       cross  => '+',
3420                     },
3421        html2     => { space  => '&nbsp;',
3422                       horiz  => '-',
3423                       vert   => '|',
3424                       el_d_r => '+',
3425                       el_u_r => '+',
3426                       el_d_l => '+',
3427                       el_u_l => '+',
3428                       tee_l  => '+',
3429                       tee_r  => '+',
3430                       tee_u  => '+',
3431                       tee_d  => '+',
3432                       half_l => '-',
3433                       half_r => '-',
3434                       half_u => '|',
3435                       half_d => '|',
3436                       cross  => '+',
3437                     },
3438        utf8_symb => { space  => ' ',
3439                       horiz  => chr(226) . chr(148) . chr(128),
3440                       vert   => chr(226) . chr(148) . chr(130),
3441                       el_d_r => chr(226) . chr(148) . chr(140),
3442                       el_u_r => chr(226) . chr(148) . chr(148),
3443                       el_d_l => chr(226) . chr(148) . chr(144),
3444                       el_u_l => chr(226) . chr(148) . chr(152),
3445                       tee_l  => chr(226) . chr(148) . chr(164),
3446                       tee_r  => chr(226) . chr(148) . chr(156),
3447                       tee_u  => chr(226) . chr(148) . chr(180),
3448                       tee_d  => chr(226) . chr(148) . chr(172),
3449                       half_l => chr(226) . chr(149) . chr(180),
3450                       half_r => chr(226) . chr(149) . chr(182),
3451                       half_u => chr(226) . chr(149) . chr(181),
3452                       half_d => chr(226) . chr(149) . chr(183),
3453                       cross  => chr(226) . chr(148) . chr(188),
3454                     },
3455        html_symb => { space  => '&nbsp;',
3456                       horiz  => '&#9472;',
3457                       vert   => '&#9474;',
3458                       el_d_r => '&#9484;',
3459                       el_u_r => '&#9492;',
3460                       el_d_l => '&#9488;',
3461                       el_u_l => '&#9496;',
3462                       tee_l  => '&#9508;',
3463                       tee_r  => '&#9500;',
3464                       tee_u  => '&#9524;',
3465                       tee_d  => '&#9516;',
3466                       half_l => '&#9588;',
3467                       half_r => '&#9590;',
3468                       half_u => '&#9589;',
3469                       half_d => '&#9591;',
3470                       cross  => '&#9532;',
3471                     },
3472        html_tbl  => { space  => '<TD>&nbsp;</TD>',
3473                       horiz  => '<TD>&#9472;</TD>',
3474                       vert   => '<TD>&#9474;</TD>',
3475                       el_d_r => '<TD>&#9484;</TD>',
3476                       el_u_r => '<TD>&#9492;</TD>',
3477                       el_d_l => '<TD>&#9488;</TD>',
3478                       el_u_l => '<TD>&#9496;</TD>',
3479                       tee_l  => '<TD>&#9508;</TD>',
3480                       tee_r  => '<TD>&#9500;</TD>',
3481                       tee_u  => '<TD>&#9524;</TD>',
3482                       tee_d  => '<TD>&#9516;</TD>',
3483                       half_l => '<TD>&#9588;</TD>',
3484                       half_r => '<TD>&#9590;</TD>',
3485                       half_u => '<TD>&#9589;</TD>',
3486                       half_d => '<TD>&#9591;</TD>',
3487                       cross  => '<TD>&#9532;</TD>',
3488                     },
3489      );
3490    
3491    #  Define some synonyms
3492    $char_set{ html } = $char_set{ html_symb };
3493    $char_set{ line } = $char_set{ html_symb };
3494    $char_set{ symb } = $char_set{ html_symb };
3495    $char_set{ text } = $char_set{ text1 };
3496    $char_set{ utf8 } = $char_set{ utf8_symb };
3497    
3498    
3499  #===============================================================================  #===============================================================================
3500  #  Make a text plot of a tree:  #  Make a text plot of a tree:
3501  #  #
3502  #     $node   newick tree root node  #  @lines = text_plot_newick( $node, $width, $min_dx, $dy )
3503  #     $width  the approximate characters for the tree without labels  #  @lines = text_plot_newick( $node, \%options )
3504  #     $min_dx the minimum horizontal branch length  #
3505  #     $dy     the vertical space per taxon  #     $node   # newick tree root node
3506    #     $width  # the approximate characters for the tree without labels (D = 68)
3507    #     $min_dx # the minimum horizontal branch length (D = 2)
3508    #     $dy     # the vertical space per taxon (D = 1, most compressed)
3509    #
3510    #  Options:
3511    #
3512    #    dy     => nat_number    # the vertical space per taxon
3513    #    chars  => key           # line drawing character set:
3514    #                            #     html_unicode
3515    #                            #     text (default)
3516    #    min_dx => whole_number  # the minimum horizontal branch length
3517    #    width  => whole_number  # approximate tree width without labels
3518  #  #
 #  @textlines = text_plot_newick( $node, $width (D=68), $min_dx (D=2), $dy (D=1) )  
3519  #===============================================================================  #===============================================================================
3520  sub text_plot_newick {  sub text_plot_newick
3521      my ( $node, $width, $min_dx, $dy ) = @_;  {
3522        my $node = shift @_;
3523      array_ref( $node ) || die "Bad node passed to text_plot_newick\n";      array_ref( $node ) || die "Bad node passed to text_plot_newick\n";
3524      defined( $min_dx ) and ( $min_dx >=  0 ) or $min_dx =  2;  
3525        my ( $opts, $width, $min_dx, $dy, $chars, $cells );
3526        if ( $_[0] && ref $_[0] eq 'HASH' )
3527        {
3528            $opts = shift;
3529        }
3530        else
3531        {
3532            $opts = {};
3533            ( $width, $min_dx, $dy ) = @_;
3534        }
3535    
3536        $chars  = $opts->{ chars  } if defined $opts->{ chars  };
3537        $dy     = $opts->{ dy     } if defined $opts->{ dy     };
3538        $min_dx = $opts->{ min_dx } if defined $opts->{ min_dx };
3539        $width  = $opts->{ width  } if defined $opts->{ width  };
3540        $cells  = $opts->{ cells  } if defined $opts->{ cells  };
3541    
3542        defined( $chars ) and ( $char_set{ $chars } ) or $chars = $default_chars;
3543        my $ch = $char_set{ $chars };
3544    
3545      defined(     $dy ) and (     $dy >=  1 ) or     $dy =  1;      defined(     $dy ) and (     $dy >=  1 ) or     $dy =  1;
3546      defined( $width  )                       or  $width = 68;      defined( $min_dx ) and ( $min_dx >=  0 ) or $min_dx =  2;
3547        defined(  $width ) and (  $width >=  1 ) or  $width = 68;
3548    
3549      $min_dx = int( $min_dx );      $min_dx = int( $min_dx );
3550      $dy     = int( $dy );      $dy     = int( $dy );
# Line 3373  Line 3558 
3558      #  Generate the lines of the tree one by one:      #  Generate the lines of the tree one by one:
3559    
3560      my ( $y1, $y2 ) = @{ $hash->{ $node } };      my ( $y1, $y2 ) = @{ $hash->{ $node } };
3561      map { text_tree_row( $node, $hash, $_, "", "+" ) } ( $y1 .. $y2 );  
3562        my @lines = map { text_tree_row( $node, $hash, $_, [], $ch->{tee_l} , $ch ) } ( $y1 .. $y2 );
3563        if ( $cells )
3564        {
3565            my $nmax = 0;
3566            foreach ( @lines ) { $nmax = @$_ if @$_ > $nmax }
3567            foreach ( @lines )
3568            {
3569                @$_ = map { "<TD>$_</TD>" } @$_;
3570                my $span = $nmax - @$_ + 1;
3571                $_->[-1] =~ s/^<TD>/<TD NoWrap ColSpan=$span>/;
3572            }
3573        }
3574    
3575        map { join '', @$_ } @lines;
3576  }  }
3577    
3578  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3579  #  ( $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 )
3580  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3581  sub layout_printer_plot {  sub layout_printer_plot
3582    {
3583      my ( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy ) = @_;      my ( $node, $hash, $x0, $y0, $x_scale, $min_dx, $dy ) = @_;
3584      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";
3585      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";
# Line 3435  Line 3635 
3635    
3636    
3637  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3638  #  Debug routine  #  \@line = text_tree_row( $node, $hash, $row, \@line, $symb, \%chars )
 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  
 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 . "  " ) }  
 }  
   
   
 #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  
 #  $line = text_tree_row( $node, $hash, $row, $line, $symb )  
3639  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -  #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3640  sub text_tree_row {  sub text_tree_row
3641      my ( $node, $hash, $row, $line, $symb ) = @_;  {
3642        my ( $node, $hash, $row, $line, $symb, $ch ) = @_;
3643    
3644      my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };      my ( $y1, $y2, $x0, $x, $y, $yn1, $yn2 ) = @{ $hash->{ $node } };
3645      if ( $row < $y1 || $row > $y2 ) { return $line }      if ( $row < $y1 || $row > $y2 ) { return $line }
3646    
3647      if ( length( $line ) < $x0 ) { $line .= " " x ( $x0 - length( $line ) ) }      if ( @$line < $x0 ) { push @$line, ($ch->{space}) x ( $x0 - @$line ) }
3648    
3649      if ( $row == $y ) {      if ( $row == $y ) {
3650          $line = substr( $line, 0, $x0 ) . $symb . (( $x > $x0 ) ? "-" x ($x - $x0) : "");          @$line = ( @$line[ 0 .. $x0-1 ],
3651                       $symb,
3652                       ( ( $x > $x0 ) ? ($ch->{horiz}) x ($x - $x0) : () )
3653                     );
3654      }      }
3655    
3656      elsif ( $row > $yn1 && $row < $yn2 ) {      elsif ( $row > $yn1 && $row < $yn2 ) {
3657          if ( length( $line ) < $x ) { $line .= " " x ( $x - length( $line ) ) . "|" }          if ( @$line < $x ) { push @$line, ($ch->{space}) x ( $x - @$line ), $ch->{vert} }
3658          else { substr( $line, $x ) = "|" }          else               { $line->[$x] = $ch->{vert} }
3659      }      }
3660    
3661      my @dl = newick_desc_list( $node );      my @dl = newick_desc_list( $node );
3662    
3663      if ( @dl < 1 ) {      if ( @dl < 1 ) {
3664          $line .= " " . $node->[1];          push @$line, $ch->{space}, newick_lbl( $node );
3665      }      }
3666    
3667      else {      else {
3668          my @list = map { [ $_, "+" ] } @dl;  #  Print symbol for line          my @list = map { [ $_, $ch->{tee_r} ] } @dl;  # Line to the right
3669          $list[ 0]->[1] = "/";          $list[ 0]->[1] = $ch->{el_d_r};
3670          $list[-1]->[1] = "\\";          $list[-1]->[1] = $ch->{el_u_r};
3671    
3672          foreach ( @list ) {          foreach ( @list ) {
3673              my ( $n, $s ) = @$_;              my ( $n, $s ) = @$_;
3674              if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {              if ( $row >= $hash->{ $n }->[0] && $row <= $hash->{ $n }->[1] ) {
3675                  $line = text_tree_row( $n, $hash, $row, $line, $s );                  $line = text_tree_row( $n, $hash, $row, $line, $s, $ch );
3676              }              }
3677           }           }
3678    
3679          if ( $row == $y ) { substr( $line, $x, 1 ) = "+" }          if ( $row == $y )
3680            {
3681                if ( $line->[$x] eq $ch->{horiz} )
3682                {
3683                    $line->[$x] = $ch->{tee_l};
3684                }
3685                else
3686                {
3687                    $line->[$x] = add_left_line( $ch, $line->[$x] );
3688                }
3689            }
3690      }      }
3691    
3692      return $line;      return $line;
3693  }  }
3694    
3695    
3696    #  To correctly resolve an ambuiguity, order matters:
3697    
3698    my @symbs = qw( space   horiz   vert    cross
3699                    el_d_l  el_u_l  el_d_r  el_u_r
3700                    tee_l   tee_r   tee_u   tee_d
3701                    half_l  half_r  half_u  half_d
3702                  );
3703    
3704    my %with_left = ( space  => 'half_l',
3705                      horiz  => 'horiz',
3706                      vert   => 'tee_l',
3707                      el_d_r => 'tee_d',
3708                      el_u_r => 'tee_u',
3709                      el_d_l => 'el_d_l',
3710                      el_u_l => 'el_u_l',
3711                      tee_l  => 'tee_l',
3712                      tee_r  => 'cross',
3713                      tee_u  => 'tee_u',
3714                      tee_d  => 'tee_d',
3715                      half_l => 'half_l',
3716                      half_r => 'horiz',
3717                      half_u => 'el_u_l',
3718                      half_d => 'el_d_l',
3719                      cross  => 'cross',
3720                    );
3721    
3722    my %add_left;
3723    
3724    sub add_left_line
3725    {
3726        my ( $ch, $c ) = @_;
3727    
3728        #  Build the translation table for the character set, if necessary:
3729        if ( ! $add_left{ $ch } )
3730        {
3731            %{ $add_left{ $ch } } = map { $ch->{ $_ } => $ch->{ $with_left{ $_ } } }
3732                                    @symbs;
3733        }
3734    
3735        return $add_left{ $ch }->{ $c };
3736    }
3737    
3738    
3739    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3740    #  Debug routine
3741    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3742    sub dump_tree {
3743        my ( $node, $prefix ) = @_;
3744        defined( $prefix ) or $prefix = "";
3745        print STDERR $prefix, join(", ", @$node), "\n";
3746        my @dl = $node->[0] ? @{$node->[0]} : ();
3747        foreach ( @dl ) { dump_tree( $_, $prefix . "  " ) }
3748        $prefix or print STDERR "\n";
3749    }
3750    
3751    
3752    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3753    #  Debug routine
3754    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3755    sub dump_tree_hash {
3756        my ( $node, $hash, $prefix ) = @_;
3757        defined( $prefix ) or print STDERR "node; [ y1, y2, x0, x, y, yn1, yn2 ]\n" and $prefix = "";
3758        print STDERR $prefix, join(", ", @$node), "; ", join(", ", @{ $hash->{ $node } } ), "\n";
3759        my @dl = $node->[0] ? @{$node->[0]} : ();
3760        foreach (@dl) { dump_tree_hash( $_, $hash, $prefix . "  " ) }
3761    }
3762    
3763    
3764  #===============================================================================  #===============================================================================
3765  #  Open an input file stream:  #  Open an input file stream:
3766  #  #

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3