[Bioperl-guts-l] bioperl-live/Bio/Tree Cladogram.pm,1.1,1.2

Gabriel Valiente valiente at pub.open-bio.org
Fri Dec 31 07:39:04 EST 2004


Update of /home/repository/bioperl/bioperl-live/Bio/Tree
In directory pub.open-bio.org:/tmp/cvs-serv11267/Bio/Tree

Modified Files:
	Cladogram.pm 
Log Message:
A Cladogram and Tanglegram drawing module


Index: Cladogram.pm
===================================================================
RCS file: /home/repository/bioperl/bioperl-live/Bio/Tree/Cladogram.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Cladogram.pm	30 Dec 2004 18:28:18 -0000	1.1
--- Cladogram.pm	31 Dec 2004 12:39:02 -0000	1.2
***************
*** 37,45 ****
  Bio::Tree::Draw::Cladogram is a Perl tool for drawing Bio::Tree::Tree
  objects in Encapsulated PostScript (EPS) format. It can be utilized
! both for displaying a single phylogenetic tree and for the comparative
! display of two phylogenetic trees, such as a gene tree and a species
! tree, a host tree and a parasite tree, two alternative trees for the
! same set of taxa, or two alternative trees for overlapping sets of
! taxa.
  
  Phylogenetic trees are drawn as rectangular cladograms, with
--- 37,45 ----
  Bio::Tree::Draw::Cladogram is a Perl tool for drawing Bio::Tree::Tree
  objects in Encapsulated PostScript (EPS) format. It can be utilized
! both for displaying a single phylogenetic tree (a cladogram) and for
! the comparative display of two phylogenetic trees (a tanglegram) such
! as a gene tree and a species tree, a host tree and a parasite tree,
! two alternative trees for the same set of taxa, or two alternative
! trees for overlapping sets of taxa.
  
  Phylogenetic trees are drawn as rectangular cladograms, with
***************
*** 49,54 ****
  flushed to the right. Two Bio::Tree::Tree objects are drawn with the
  first tree oriented left-to-right and the second tree oriented
! right-to-left, and with corresponding taxa connected by straight
! lines.
  
  This is a preliminary release of Bio::Tree::Draw::Cladogram. Future
--- 49,58 ----
  flushed to the right. Two Bio::Tree::Tree objects are drawn with the
  first tree oriented left-to-right and the second tree oriented
! right-to-left, and with corresponding taxa connected by straight lines
! in a shade of gray. Each correspondence between a $taxon1 of the first
! tree and a $taxon2 of the second tree is established by setting
! $taxon1->add_tag_value('connection',$taxon2). Thus, a taxon of the
! first tree can be connected to more than one taxon of the second tree,
! and vice versa.
  
  This is a preliminary release of Bio::Tree::Draw::Cladogram. Future
***************
*** 112,116 ****
  my $t1;        # first Bio::Tree::Tree object
  my $t2;        # second Bio::Tree::Tree object
- my %conn;      # connection between $t1 and $t2 taxa
  my $width;     # total drawing width
  my $height;    # total drawing height
--- 116,119 ----
***************
*** 119,122 ****
--- 122,126 ----
  my $tipwidth1; # width of longest label among $t1 taxa
  my $tipwidth2; # width of longest label among $t2 taxa
+ my $tiplen2;   # number of characters of longest label among $t2 taxa
  
  =head2 new
***************
*** 128,132 ****
   Args    : -tree => Bio::Tree::Tree object
             -second => Bio::Tree::Tree object (optional)
-            -connection => hash of taxa indexed by taxa (optional)
             -aspect => width to height ratio [real] (optional)
             -top => top margin [integer] (optional)
--- 132,135 ----
***************
*** 143,148 ****
  
    my $self = $class->SUPER::new(@args);
!   ($t1, $t2, %conn, my $aspect, my $top, my $bottom, my $left, my $right,
!     $tip, my $column) = $self->_rearrange([qw(TREE SECOND ASPECT CONNECTION
      TOP BOTTOM LEFT RIGHT TIP COLUMN)], @args);
    $aspect ||= 2/(sqrt 5+1); # golden ratio
--- 146,151 ----
  
    my $self = $class->SUPER::new(@args);
!   ($t1, $t2, my $aspect, my $top, my $bottom, my $left, my $right,
!     $tip, my $column) = $self->_rearrange([qw(TREE SECOND ASPECT
      TOP BOTTOM LEFT RIGHT TIP COLUMN)], @args);
    $aspect ||= 2/(sqrt 5+1); # golden ratio
***************
*** 152,161 ****
    $right ||= 10;
    $tip ||= 5;
!   $column ||= 20;
  
    # An alternative would be to let the user set $width and $height in
    # points and to scale down everything to fit the desired
    # dimensions. However, the final EPS can later be scaled down to any
!   # desired size.
  
    my @taxa1 = $t1->get_leaf_nodes;
--- 155,203 ----
    $right ||= 10;
    $tip ||= 5;
!   $column ||= 60;
! 
!   # Roughly, a cladogram is set according to the following parameters.
! 
!   #################################
!   #                           # T #   $top (T, top margin)
!   #        +---------+ XXX    #   #   $bottom (B, bottom margin)
!   #        |                  #   #   $left (L, left margin)
!   #        |                  #   #   $right (R, right margin)
!   #   +----+                  #   #   $tip (X, extra tip space)
!   #        |    +----+ XXXX   #   #   $width (total drawing width)
!   #        |    |             #   #   $height (total drawing height)
!   #        +----+             # Y #   $aspect ($width / $height)
!   #             |             #   #   $xstep (S, stem length)
!   #             +----+ XX     #   #   $ystep (Y, space between taxa)
!   #                           # B #   $tiplen (string length of longest name)
!   #################################   $tipwidth (N, size of longest name)
!   # L         S       X  N  R #
!   #############################
! 
!   # A tanglegram is roughly set as follows. The only additional
!   # parameter is $column (C, length of connection lines between taxa
!   # of the two trees), but $tip occurs four times, and $tiplen and
!   # $tipwidth differ for the first and the second tree.
! 
!   ###########################################################
!   #                                                         #
!   #        +---------+ XXX  ----- XXXXXX +----+             #
!   #        |                                  |             #
!   #        |                                  +----+        #
!   #   +----+                                  |    |        #
!   #        |    +----+ XXXX -----    XXX +----+    |        #
!   #        |    |                                  +----+   #
!   #        +----+                                  |        #
!   #             |                                  |        #
!   #             +----+ XX   -----   XXXX +---------+        #
!   #                                                         #
!   ###########################################################
!   # L                 X    X  C  X      X                 R #
!   ###########################################################
  
    # An alternative would be to let the user set $width and $height in
    # points and to scale down everything to fit the desired
    # dimensions. However, the final EPS can later be scaled down to any
!   # desired size anyway.
  
    my @taxa1 = $t1->get_leaf_nodes;
***************
*** 169,173 ****
    my @taxa2;
    my $root2;
-   my $tiplen2;
  
    my $ystep = 10;
--- 211,214 ----
***************
*** 187,191 ****
    $height = $bottom + $ystep * (@taxa1 - 1) + $top;
  
!   $width = $aspect * $height;
    $width -= ($left + $tip + $tipwidth1 + $right);
  
--- 228,232 ----
    $height = $bottom + $ystep * (@taxa1 - 1) + $top;
  
!   $width = $aspect * $height + 200;
    $width -= ($left + $tip + $tipwidth1 + $right);
  
***************
*** 198,205 ****
  
    $width = $left + $tipwidth1 + $tip + $xstep * $depth + $right;
    if ($t2) {
      $width += $tip + $column + $tip + $tipwidth2 + $tip;
    }
!   $height = $bottom + $ystep * (@taxa1 - 1) + $top;
  
    my $x = $left + $xstep * ($root1->height + 1) + $tip;
--- 239,273 ----
  
    $width = $left + $tipwidth1 + $tip + $xstep * $depth + $right;
+   $height = $bottom + $ystep * (@taxa1 - 1) + $top;
    if ($t2) {
      $width += $tip + $column + $tip + $tipwidth2 + $tip;
+     if ( scalar(@taxa2) > scalar(@taxa1) ) {
+       $height = $bottom + $ystep * (@taxa2 - 1) + $top;
+     }
    }
! 
!   ###########################################################################
!   # A problem with this approach is that for long taxa names, stems
!   # can be much too short (even of negative length) in order to
!   # achieve the desired aspect ratio. The following solution consists
!   # of setting $xstep (the stem length) to an absolute length and
!   # rescaling $ystep (the vertical space between taxa names) to achive
!   # the desired aspect ratio.
!   ###########################################################################
!   my $stems = $root1->height + 1;
!   if ($t2) { $stems += $root2->height + 1; }
!   my $labels = $tipwidth1;
!   if ($t2) { $labels += $tipwidth2; }
!   $xstep = 20;
!   $width = $left + $stems * $xstep + $tip + $labels + $right;
!   if ($t2) { $width += $tip + $column + $tip + $tip; }
!   $height = $aspect * $width;
!   $ystep = $height / scalar(@taxa1);
!   if ($t2) {
!     if (scalar(@taxa2) > scalar(@taxa1)) {
!       $ystep = $height / scalar(@taxa2);
!     }
!   }
!   ###########################################################################
  
    my $x = $left + $xstep * ($root1->height + 1) + $tip;
***************
*** 341,345 ****
        print INFO $xx{$taxon} - $tipwidth2 - $tip, " ",
          $yy{$taxon} - 3, " moveto\n";
!       print INFO "(", $taxon->id, ") show\n";
      }
  
--- 409,414 ----
        print INFO $xx{$taxon} - $tipwidth2 - $tip, " ",
          $yy{$taxon} - 3, " moveto\n";
!       my $format = "(%" . $tiplen2 . "s) show\n";
!       printf INFO $format, $taxon->id;
      }
  
***************
*** 367,385 ****
      my @taxa2 = $t2->get_leaf_nodes;
  
!     my $connection = scalar(keys(%conn));
!     if ($connection eq 1) {
! 
!       # set default connection between $t1 and $t2 taxa, unless
!       # overridden by %conn
  
!       foreach my $taxon1 (@taxa1) {
!         my $x1 = $xx{$taxon1} + $tip + $tipwidth1 + $tip;
!         my $y1 = $yy{$taxon1};
!         foreach my $taxon2 (@taxa2) {
!           if ($taxon1->id eq $taxon2->id) {
! 	    $conn{$taxon1} = $taxon2;
! 	    last;
!           }
!         }
        }
      }
--- 436,448 ----
      my @taxa2 = $t2->get_leaf_nodes;
  
!     # set default connection between $t1 and $t2 taxa, unless
!     # overridden by the user (the latter not implemented yet)
  
!     foreach my $taxon1 (@taxa1) {
!       foreach my $taxon2 (@taxa2) {
! 	if ($taxon1->id eq $taxon2->id) {
! 	  $taxon1->add_tag_value('connection',$taxon2);
! 	  last;
! 	}
        }
      }
***************
*** 389,396 ****
      print INFO "stroke\n";
      print INFO "0.5 setgray\n";
      foreach my $taxon1 (@taxa1) {
!       if (defined $conn{$taxon1}) {
!         my $taxon2 = $conn{$taxon1};
!         my $x1 = $xx{$taxon1} + $tip + $tipwidth1 + $tip;
          my $y1 = $yy{$taxon1};
          my $x2 = $xx{$taxon2} - $tip - $tipwidth2 - $tip;
--- 452,460 ----
      print INFO "stroke\n";
      print INFO "0.5 setgray\n";
+ 
      foreach my $taxon1 (@taxa1) {
!       my @match = $taxon1->get_tag_values('connection');
!       foreach my $taxon2 (@match) {
! 	my $x1 = $xx{$taxon1} + $tip + $tipwidth1 + $tip;
          my $y1 = $yy{$taxon1};
          my $x2 = $xx{$taxon2} - $tip - $tipwidth2 - $tip;



More information about the Bioperl-guts-l mailing list