branch-1-6/Bio/PhyloNetwork/TreeFactoryX.pm

   1 # $Id$
   2 #
   3 # Module for Bio::PhyloNetwork::TreeFactoryX
   4 #
   5 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   6 #
   7 # Cared for by Gabriel Cardona <gabriel(dot)cardona(at)uib(dot)es>
   8 #
   9 # Copyright Gabriel Cardona
  10 #
  11 # You may distribute this module under the same terms as perl itself
  12
  13 # POD documentation - main docs before the code
  14
  15 =head1 NAME
  16
  17 Bio::PhyloNetwork::TreeFactoryX - Module to sequentially generate
  18 Phylogenetic Trees
  19
  20 =head1 SYNOPSIS
  21
  22  use strict;
  23  use warnings;
  24
  25  use Bio::PhyloNetwork;
  26  use Bio::PhyloNetwork::TreeFactory;
  27
  28  # Will generate sequentially all the 15 binary phylogetic
  29  # trees with 4 leaves
  30
  31  my $factory=Bio::PhyloNetwork::TreeFactory->new(-numleaves=>4);
  32
  33  my @nets;
  34
  35  while (my $net=$factory->next_network()) {
  36    push @nets,$net;
  37    print "".(scalar @nets).": ".$net->eNewick()."\n";
  38  }
  39
  40 =head1 DESCRIPTION
  41
  42 Sequentially builds a (binary) phylogenetic tree each time
  43 next_network is called.
  44
  45 =head1 AUTHOR
  46
  47 Gabriel Cardona, gabriel(dot)cardona(at)uib(dot)es
  48
  49 =head1 SEE ALSO
  50
  51 L<Bio::PhyloNetwork>
  52
  53 =head1 APPENDIX
  54
  55 The rest of the documentation details each of the object methods.
  56
  57 =cut
  58
  59 package Bio::PhyloNetwork::TreeFactoryX;
  60
  61 use strict;
  62 use warnings;
  63
  64 use base qw(Bio::Root::Root);
  65
  66 use Bio::PhyloNetwork;
  67
  68 =head2 new
  69
  70  Title   : new
  71  Usage   : my $factory = new Bio::PhyloNetwork::TreeFactory();
  72  Function: Creates a new Bio::PhyloNetwork::TreeFactory
  73  Returns : Bio::PhyloNetwork::RandomFactory
  74  Args    : -numleaves => integer
  75             OR
  76            -leaves => reference to an array (of leaves names)
  77
  78 Returns a Bio::PhyloNetwork::TreeFactory object. Such an object will
  79 sequentially create binary phylogenetic trees
  80 each time next_network is called.
  81
  82 If the parameter -leaves=E<gt>\@leaves is given, then the set of leaves of
  83 these networks will be @leaves. If it is given the parameter
  84 -numleaves=E<gt>$numleaves, then the set of leaves will be "l1"..."l$numleaves".
  85
  86 =cut
  87
  88 sub new {
  89   my ($pkg,@args)=@_;
  90
  91   my $self=$pkg->SUPER::new(@args);
  92
  93   my ($leavesR,$numleaves,$numhybrids)=
  94     $self->_rearrange([qw(LEAVES
  95                           NUMLEAVES
  96                           NUMHYBRIDS)],@args);
  97
  98   my @leaves;
  99   if ((! defined $leavesR) && (defined $numleaves)) {
 100     @leaves=map {"l$_"} (1..$numleaves);
 101     $leavesR=\@leaves;
 102   }
 103   if (! defined $leavesR) {
 104     $self->throw("No leaves set neither numleaves given");
 105   }
 106   @leaves=@$leavesR;
 107   $self->{leaves}=$leavesR;
 108
 109   $numleaves=@leaves;
 110   $self->{numleaves}=$numleaves;
 111   if ($numleaves > 2) {
 112     my @leavesparent=@leaves;
 113     my $newleaf=pop @leavesparent;
 114     $self->{newleaf}=$newleaf;
 115     $self->{parent}=
 116       new($pkg,-leaves=>\@leavesparent);
 117     my $oldnet=$self->{parent}->next_network_new();
 118     $self->{oldnet}=$oldnet;
 119     my @candidates=$oldnet->nodes();
 120     $self->{candidates}=\@candidates;
 121   }
 122   $self->{index}=0;
 123   $self->{found}=[];
 124   $self->{thrown}=0;
 125   bless($self,$pkg);
 126 }
 127
 128 =head2 next_network
 129
 130  Title   : next_network
 131  Usage   : my $net=$factory->next_network()
 132  Function: returns a tree
 133  Returns : Bio::PhyloNetwork
 134  Args    : none
 135
 136 =cut
 137
 138 sub next_network_new {
 139   my ($self)=@_;
 140
 141   my $n=$self->{numleaves};
 142   if ($self->{numleaves} == 2) {
 143     if ($self->{index} == 0) {
 144       my $graph=Graph::Directed->new();
 145       $graph->add_edges("t0",$self->{leaves}->[0],"t0",$self->{leaves}->[1]);
 146       my $net=Bio::PhyloNetwork->new(-graph=>$graph);
 147       $self->{index}++;
 148       $self->{found}=[$net];
 149       return $net;
 150     }
 151     else {
 152       return 0;
 153     }
 154   }
 155   else {
 156     if ($self->{index} == (scalar @{$self->{candidates}})) {
 157       my $oldnet=$self->{parent}->next_network_new();
 158       if (! $oldnet) {
 159         return 0;
 160       }
 161       $self->{oldnet}=$oldnet;
 162       my @candidates=$oldnet->nodes();
 163       $self->{candidates}=\@candidates;
 164       $self->{index}=0;
 165     }
 166     my $graph=$self->{oldnet}->{graph}->copy();
 167     my $u=$self->{candidates}->[$self->{index}];
 168     foreach my $w ($graph->predecessors($u)) {
 169       $graph->delete_edge($w,$u);
 170       $graph->add_edge($w,"t$n");
 171     }
 172     $graph->add_edge("t$n",$u);
 173     $graph->add_edge("t$n",$self->{newleaf});
 174     my $net=Bio::PhyloNetwork->new(-graph=>$graph);
 175     $self->{index}++;
 176     my @found=@{$self->{found}};
 177     push @found,$net;
 178     $self->{found}=\@found;
 179     return $net;
 180   }
 181 }
 182
 183 sub next_network_repeated {
 184   my ($self)=@_;
 185
 186   return 0 if ($self->{thrown} >= (scalar @{$self->{found}}));
 187   $self->{thrown}=$self->{thrown}+1;
 188   return $self->{found}->[$self->{thrown}-1];
 189 }
 190
 191 sub next_network {
 192   my ($self)=@_;
 193   return $self->next_network_new();
 194 }
 195
 196 1;