[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.6, Tue Dec 19 18:01:14 2006 UTC revision 1.7, Fri Jan 12 23:45:29 2007 UTC
# Line 44  Line 44 
44  #  #
45  #     $tree = \@rootnode;  #     $tree = \@rootnode;
46  #  #
47  #     @node = ( \@desc,  #  reference to list of descendants  #     $node = [ \@desc,  #  reference to list of descendants
48  #                $label, #  node label  #                $label, #  node label
49  #                $x,     #  branch length  #                $x,     #  branch length
50  #               \@c1,    #  reference to comment list 1  #               \@c1,    #  reference to comment list 1
# Line 52  Line 52 
52  #               \@c3,    #  reference to comment list 3  #               \@c3,    #  reference to comment list 3
53  #               \@c4,    #  reference to comment list 4  #               \@c4,    #  reference to comment list 4
54  #               \@c5     #  reference to comment list 5  #               \@c5     #  reference to comment list 5
55  #             )  #             ]
56  #  #
57  #  At present, no routine tests or enforces the length of the list (a single  #  At present, no routine tests or enforces the length of the list (a single
58  #  element list could be a valid internal node).  #  element list could be a valid internal node).
# Line 63  Line 63 
63  #  time, but is different from the prolog representation.  #  time, but is different from the prolog representation.
64  #  #
65  #  #
66    #  Ross Overbeek has a different tree node structure:
67    #
68    #     $node = [ Label,
69    #               DistanceToParent,
70    #               [ ParentPointer, ChildPointer1, ... ],
71    #               [ Name1\tVal1, Name2\tVal2, ... ]
72    #             ]
73    #
74    #  So:
75    #
76    #===============================================================================
77    #  Tree format interconversion:
78    #===============================================================================
79    #
80    #  $gjonewick = overbeek_to_gjonewick( $overbeek )
81    #  $overbeek  = gjonewick_to_overbeek( $gjonewick )
82    #
83  #===============================================================================  #===============================================================================
84  #  Tree data extraction:  #  Tree data extraction:
85  #===============================================================================  #===============================================================================
# Line 157  Line 174 
174  #  $n_changed = newick_set_undefined_branches( $node, $x )  #  $n_changed = newick_set_undefined_branches( $node, $x )
175  #  $n_changed = newick_set_all_branches( $node, $x )  #  $n_changed = newick_set_all_branches( $node, $x )
176  #  $n_changed = newick_fix_negative_branches( $tree )  #  $n_changed = newick_fix_negative_branches( $tree )
177    #  $node      = newick_rescale_branches( $node, $factor )
178  #  #
179  #  Modify rooting and/or order:  #  Modify rooting and/or order:
180  #  #
# Line 188  Line 206 
206  #  #
207  #   writeNewickTree( $tree )  #   writeNewickTree( $tree )
208  #   writeNewickTree( $tree, $file )  #   writeNewickTree( $tree, $file )
209  #   writePrettyTree( $tree, $file )  #   writeNewickTree( $tree, \*FH )
210  #  fwriteNewickTree( $file, $tree )  #  fwriteNewickTree( $file, $tree )  # Matches the C arg list for f... I/O
211  #  $treestring = swriteNewickTree( $tree )  #  $treestring = swriteNewickTree( $tree )
212  #  $treestring = formatNewickTree( $tree )  #  $treestring = formatNewickTree( $tree )
213  #  @textlines  = text_plot_newick( $node, $width, $min_dx, $dy )  #  @textlines  = text_plot_newick( $node, $width, $min_dx, $dy )
214  #   printer_plot_newick( $node, $file, $width, $min_dx, $dy )  #   printer_plot_newick( $node, $file, $width, $min_dx, $dy )
215  #  #
216    #  $tree  = read_newick_tree( $file )  # reads to a semicolon
217    #  @trees = read_newick_trees( $file ) # reads to end of file
218  #  $tree = parse_newick_tree_str( $string )  #  $tree = parse_newick_tree_str( $string )
219  #  #
220  #===============================================================================  #===============================================================================
# Line 204  Line 224 
224    
225  our @ISA = qw(Exporter);  our @ISA = qw(Exporter);
226  our @EXPORT = qw(  our @EXPORT = qw(
227            overbeek_to_gjonewick
228            gjonewick_to_overbeek
229    
230          newick_is_rooted          newick_is_rooted
231          newick_is_unrooted          newick_is_unrooted
232          tree_rooted_on_tip          tree_rooted_on_tip
# Line 241  Line 264 
264          newick_set_undefined_branches          newick_set_undefined_branches
265          newick_set_all_branches          newick_set_all_branches
266          newick_fix_negative_branches          newick_fix_negative_branches
267            newick_rescale_branches
268    
269          normalize_newick_tree          normalize_newick_tree
270          reverse_newick_tree          reverse_newick_tree
# Line 267  Line 291 
291          fwriteNewickTree          fwriteNewickTree
292          strNewickTree          strNewickTree
293          formatNewickTree          formatNewickTree
294    
295            read_newick_tree
296            read_newick_trees
297          parse_newick_tree_str          parse_newick_tree_str
298    
299          printer_plot_newick          printer_plot_newick
# Line 307  Line 334 
334    
335  use gjolists qw(  use gjolists qw(
336          common_prefix          common_prefix
         common_and_unique  
337          unique_suffixes          unique_suffixes
338    
         unique_set  
339          duplicates          duplicates
340          random_order          random_order
341    
         union  
342          intersection          intersection
343          set_difference          set_difference
344          );          );
# Line 332  Line 356 
356    
357    
358  #===============================================================================  #===============================================================================
359    #  Interconvert Overbeek and gjonewick trees:
360    #===============================================================================
361    
362    sub overbeek_to_gjonewick
363    {
364        return () unless ref( $_[0] ) eq 'ARRAY';
365        my ( $lbl, $x, $desc ) = @{ $_[0] };
366        my ( undef, @desc ) = ( $desc && ref( $desc ) eq 'ARRAY' ) ? @$desc : ();
367        [ [ map { overbeek_to_gjonewick( $_ ) } @desc ], $lbl, $x ]
368    }
369    
370    sub gjonewick_to_overbeek
371    {
372        return () unless ref( $_[0] ) eq 'ARRAY';
373        my ( $desc, $lbl, $x ) = @{ $_[0] };
374        my @desc = ( $desc && ref( $desc ) eq 'ARRAY' ) ? @$desc : ();
375        my $parent = $_[1];
376        my $node = [ $lbl, $x, undef, [] ];
377        $node->[2] = [ $parent, map { gjonewick_to_overbeek( $_, $node ) } @desc ];
378        return $node;
379    }
380    
381    #===============================================================================
382  #  Extract tree structure values:  #  Extract tree structure values:
383  #===============================================================================  #===============================================================================
384  #  #
# Line 580  Line 627 
627  #  @tips = newick_duplicated_tips( $node )  #  @tips = newick_duplicated_tips( $node )
628  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
629  sub newick_duplicated_tips {  sub newick_duplicated_tips {
630      duplicates( newick_tip_list( $_[0] ) );      gjolists::duplicates( newick_tip_list( $_[0] ) );
631  }  }
632    
633    
# Line 616  Line 663 
663      my ( $Tree1, $Tree2 ) = @_;      my ( $Tree1, $Tree2 ) = @_;
664      my ( @Tips1 ) = newick_tip_list( $Tree1 );      my ( @Tips1 ) = newick_tip_list( $Tree1 );
665      my ( @Tips2 ) = newick_tip_list( $Tree2 );      my ( @Tips2 ) = newick_tip_list( $Tree2 );
666      intersection( \@Tips1, \@Tips2 );      gjolists::intersection( \@Tips1, \@Tips2 );
667  }  }
668    
669    
# Line 737  Line 784 
784      my @rest = tips_in_newick( $tree );      my @rest = tips_in_newick( $tree );
785      my @best = map {      my @best = map {
786              my @tips = sort { lc $a cmp lc $b } tips_in_newick( $_ );              my @tips = sort { lc $a cmp lc $b } tips_in_newick( $_ );
787              @rest = set_difference( \@rest, \@tips );              @rest = gjolists::set_difference( \@rest, \@tips );
788              $tips[0];              $tips[0];
789          } newick_desc_list( $noderef );          } newick_desc_list( $noderef );
790    
# Line 856  Line 903 
903      @p2 && @p3 || return ();                             #  Were they found?      @p2 && @p3 || return ();                             #  Were they found?
904    
905      # Find the common prefix for each pair of paths      # Find the common prefix for each pair of paths
906      my @p12 = common_prefix( \@p1, \@p2 );      my @p12 = gjolists::common_prefix( \@p1, \@p2 );
907      my @p13 = common_prefix( \@p1, \@p3 );      my @p13 = gjolists::common_prefix( \@p1, \@p3 );
908      my @p23 = common_prefix( \@p2, \@p3 );      my @p23 = gjolists::common_prefix( \@p2, \@p3 );
909    
910      # Return the longest common prefix of any two paths      # Return the longest common prefix of any two paths
911      ( @p12 >= @p13 && @p12 >= @p23 ) ? @p12 :      ( @p12 >= @p13 && @p12 >= @p23 ) ? @p12 :
# Line 909  Line 956 
956      @p1 && @p2 || return undef;                          # Were they found?      @p1 && @p2 || return undef;                          # Were they found?
957    
958      # Find the unique suffixes of the two paths      # Find the unique suffixes of the two paths
959      my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 ); # Common node is lost      my ( $suf1, $suf2 ) = gjolists::unique_suffixes( \@p1, \@p2 ); # Common node is lost
960      my $d1 = @$suf1 ? distance_along_path_2( @$suf1 ) : 0;      my $d1 = @$suf1 ? distance_along_path_2( @$suf1 ) : 0;
961      my $d2 = @$suf2 ? distance_along_path_2( @$suf2 ) : 0;      my $d2 = @$suf2 ? distance_along_path_2( @$suf2 ) : 0;
962    
# Line 935  Line 982 
982      @p1 && @p2 || return undef;                          # Were they found?      @p1 && @p2 || return undef;                          # Were they found?
983    
984      # Find the unique suffixes of the two paths      # Find the unique suffixes of the two paths
985      my ( $suf1, $suf2 ) = unique_suffixes( \@p1, \@p2 ); # Common node is lost      my ( $suf1, $suf2 ) = gjolists::unique_suffixes( \@p1, \@p2 ); # Common node is lost
986      my $d1 = @$suf1 ? distance_along_path_2( @$suf1 ) : 0;      my $d1 = @$suf1 ? distance_along_path_2( @$suf1 ) : 0;
987      my $d2 = @$suf2 ? distance_along_path_2( @$suf2 ) : 0;      my $d2 = @$suf2 ? distance_along_path_2( @$suf2 ) : 0;
988    
# Line 1150  Line 1197 
1197      my ( $node, $x, $not_root ) = @_;      my ( $node, $x, $not_root ) = @_;
1198    
1199      my $n = 0;      my $n = 0;
1200      if ( $not_root ) {      if ( $not_root )
1201        {
1202          set_newick_x( $node, $x );          set_newick_x( $node, $x );
1203          $n++;          $n++;
1204      }      }
1205    
1206      foreach ( newick_desc_list( $node ) ) {      foreach ( newick_desc_list( $node ) )
1207        {
1208          $n += newick_set_all_branches( $_, $x, 1 );          $n += newick_set_all_branches( $_, $x, 1 );
1209      }      }
1210    
# Line 1164  Line 1213 
1213    
1214    
1215  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
1216    #  Rescale all branch lenghts by factor.
1217    #
1218    #  $node = newick_rescale_branches( $node, $factor )
1219    #-------------------------------------------------------------------------------
1220    sub newick_rescale_branches {
1221        my ( $node, $factor ) = @_;
1222    
1223        my $x = newick_x( $node );
1224        set_newick_x( $node, $factor * $x ) if $x;
1225    
1226        foreach ( newick_desc_list( $node ) )
1227        {
1228            newick_rescale_branches( $_, $factor );
1229        }
1230    
1231        $node;
1232    }
1233    
1234    
1235    #-------------------------------------------------------------------------------
1236  #  Set negative branches to zero.  The original tree is modfied.  #  Set negative branches to zero.  The original tree is modfied.
1237  #  #
1238  #  $n_changed = newick_fix_negative_branches( $tree )  #  $n_changed = newick_fix_negative_branches( $tree )
# Line 1404  Line 1473 
1473      #  Reorder this subtree:      #  Reorder this subtree:
1474    
1475      my $dl_ref = newick_desc_ref( $node );      my $dl_ref = newick_desc_ref( $node );
1476      @$dl_ref = random_order( @$dl_ref );      @$dl_ref = gjolists::random_order( @$dl_ref );
1477    
1478      #  Reorder descendants:      #  Reorder descendants:
1479    
# Line 2019  Line 2088 
2088  #  Tree writing and reading  #  Tree writing and reading
2089  #  #
2090  #===============================================================================  #===============================================================================
2091  #  writeNewickTree( $tree [, $file ] )  #  writeNewickTree( $tree )
2092    #  writeNewickTree( $tree, $file )
2093    #  writeNewickTree( $tree, \*FH )
2094  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
2095  sub writeNewickTree {  sub writeNewickTree {
2096      my ( $tree, $file ) = @_;      my ( $tree, $file ) = @_;
2097      $file || ( $file = \*STDOUT );      my ( $fh, $close ) = open_output( $file );
2098      print  $file  ( strNewickTree( $tree ), "\n" );      $fh or return;
2099        print  $fh  ( strNewickTree( $tree ), "\n" );
2100        close $fh if $close;
2101  }  }
2102    
2103    
# Line 2167  Line 2240 
2240    
2241    
2242  #===============================================================================  #===============================================================================
2243    #  $tree  = read_newick_tree( $file )  # reads to a semicolon
2244    #  @trees = read_newick_trees( $file ) # reads to end of file
2245    #===============================================================================
2246    
2247    sub read_newick_tree
2248    {
2249        my $file = shift;
2250        my ( $fh, $close ) = open_input( $file );
2251        my $tree;
2252        my @lines = ();
2253        while ( defined( $_ = <$fh> ) )
2254        {
2255            chomp;
2256            push @lines, $_;
2257            if ( /;/ )
2258            {
2259                $tree = parse_newick_tree_str( join( ' ', @lines ) );
2260                last;
2261            }
2262        }
2263        close $fh if $close;
2264    
2265        $tree;
2266    }
2267    
2268    
2269    sub read_newick_trees
2270    {
2271        my $file = shift;
2272        my ( $fh, $close ) = open_input( $file );
2273        my @trees = ();
2274        my @lines = ();
2275        while ( defined( $_ = <$fh> ) )
2276        {
2277            chomp;
2278            push @lines, $_;
2279            if ( /;/ )
2280            {
2281                push @trees, parse_newick_tree_str( join( ' ', @lines ) );
2282                @lines = ()
2283            }
2284        }
2285        close $fh if $close;
2286    
2287        @trees;
2288    }
2289    
2290    
2291    #===============================================================================
2292  #  Tree reader adapted from the C language reader in fastDNAml  #  Tree reader adapted from the C language reader in fastDNAml
2293  #  #
2294  #  $tree = parse_newick_tree_str( $string )  #  $tree = parse_newick_tree_str( $string )
# Line 2378  Line 2500 
2500  sub printer_plot_newick {  sub printer_plot_newick {
2501      my ( $node, $file, $width, $min_dx, $dy ) = @_;      my ( $node, $file, $width, $min_dx, $dy ) = @_;
2502    
2503      my ( $fh, $close );      my ( $fh, $close ) = open_output( $file );
2504      if ( ! defined( $file ) ) {      $fh or return;
         $fh = \*STDOUT;  
     }  
     elsif ( ref( $file ) eq 'GLOB' ) {  
         $fh = $file;  
     }  
     else {  
         open $fh, ">$file" or die "Could not open $file for writing printer_plot_newick\n";  
         $close = 1;  
     }  
2505    
2506      print $fh join( "\n", text_plot_newick( $node, $width, $min_dx, $dy ) ), "\n";      print $fh join( "\n", text_plot_newick( $node, $width, $min_dx, $dy ) ), "\n";
2507      if ( $close ) { close $fh }      if ( $close ) { close $fh }
# Line 2555  Line 2668 
2668  }  }
2669    
2670    
2671    #===============================================================================
2672    #  Open an input file stream:
2673    #
2674    #     ( $handle, undef ) = open_input(       );  # \*STDIN
2675    #     ( $handle, undef ) = open_input( \*FH  );
2676    #     ( $handle, 1     ) = open_input( $file );  # need to close $handle
2677    #
2678    #===============================================================================
2679    sub open_input
2680    {
2681        my $file = shift;
2682        my $fh;
2683        if    ( ! defined( $file ) )     { return ( \*STDIN ) }
2684        elsif ( ref( $file ) eq 'GLOB' ) { return ( $file   ) }
2685        elsif ( open( $fh, "<$file" ) )  { return ( $fh, 1  ) } # Need to close
2686    
2687        print STDERR "gjonewick::open_input could not open '$file' for reading\n";
2688        return undef;
2689    }
2690    
2691    
2692    #===============================================================================
2693    #  Open an output file stream:
2694    #
2695    #     ( $handle, undef ) = open_output(      );  # \*STDOUT
2696    #     ( $handle, undef ) = open_output( \*FH );
2697    #     ( $handle, 1     ) = open_output( $file ); # need to close $handle
2698    #
2699    #===============================================================================
2700    sub open_output
2701    {
2702        my $file = shift;
2703        my $fh;
2704        if    ( ! defined( $file ) )     { return ( \*STDOUT ) }
2705        elsif ( ref( $file ) eq 'GLOB' ) { return ( $file    ) }
2706        elsif ( ( open $fh, ">$file" ) ) { return ( $fh, 1   ) } # Need to close
2707    
2708        print STDERR "gjonewick::open_output could not open '$file' for writing\n";
2709        return undef;
2710    }
2711    
2712  1;  1;

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3