[Bio] / FigKernelPackages / proml.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/proml.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8, Sun Feb 11 18:35:46 2007 UTC revision 1.9, Tue Jan 19 01:55:51 2010 UTC
# Line 108  Line 108 
108                       uproot_newick                       uproot_newick
109                     );                     );
110    
   
111  sub proml  sub proml
112  {  {
113      my $align;      my $align;
# Line 163  Line 162 
162            || ref( $categories->[0] ) ne 'ARRAY'            || ref( $categories->[0] ) ne 'ARRAY'
163             )             )
164          {          {
165              print STDERR "proml::proml categories option value must be [ [ cat_rate1, ... ], site_categories ]\n";              print STDERR "proml::proml() categories option value must be [ [ cat_rate1, ... ], site_categories ]\n";
166              return ();              return ();
167          }          }
168    
# Line 177  Line 176 
176                    ||  0;                    ||  0;
177      if ( $coef_of_var < 0 )      if ( $coef_of_var < 0 )
178      {      {
179          print STDERR "proml::proml coef_of_var option value must be >= 0\n";          print STDERR "proml::proml() coef_of_var option value must be >= 0\n";
180          return ();          return ();
181      }      }
182    
183      my $gamma_bins   = int( $options{ gamma_bins } || ( $coef_of_var ? 5 : 2 ) );      my $gamma_bins   = int( $options{ gamma_bins } || ( $coef_of_var ? 5 : 2 ) );
184      if ( ( $gamma_bins < 2 )  || ( $gamma_bins > 9 ) )      if ( ( $gamma_bins < 2 )  || ( $gamma_bins > 9 ) )
185      {      {
186          print STDERR "proml::proml gamma_bins option value must be > 1 and <= 9\n";          print STDERR "proml::proml() gamma_bins option value must be > 1 and <= 9\n";
187          return ();          return ();
188      }      }
189    
# Line 193  Line 192 
192      my $invar_frac   = $options{ invar_frac } || 0;      my $invar_frac   = $options{ invar_frac } || 0;
193      if ( $invar_frac && ( $invar_frac < 0 || $invar_frac >= 1 ) )      if ( $invar_frac && ( $invar_frac < 0 || $invar_frac >= 1 ) )
194      {      {
195          print STDERR "proml::proml invar_frac option value must be >= 0 and < 1\n";          print STDERR "proml::proml() invar_frac option value must be >= 0 and < 1\n";
196          return ();          return ();
197      }      }
198    
199      my $n_jumble     = int( $options{ n_jumble }    || ( $options{ jumble_seed } ? 1 : 0) );      my $n_jumble     = int( $options{ n_jumble }    || ( $options{ jumble_seed } ? 1 : 0) );
200      if ( $n_jumble < 0 )      if ( $n_jumble < 0 )
201      {      {
202          print STDERR "proml::proml n_jumble option value must be >= 0\n";          print STDERR "proml::proml() n_jumble option value must be >= 0\n";
203          return ();          return ();
204      }      }
205    
206      my $jumble_seed  = int( $options{ jumble_seed } || 4 * int( 499999999 * rand() ) + 1 );      my $jumble_seed  = int( $options{ jumble_seed } || 4 * int( 499999999 * rand() ) + 1 );
207      if ( ( $jumble_seed <= 0)  || ( $jumble_seed % 2 != 1 ) )      if ( ( $jumble_seed <= 0)  || ( $jumble_seed % 2 != 1 ) )
208      {      {
209          print STDERR "proml::proml jumble_seed option value must be an odd number > 0\n";          print STDERR "proml::proml() jumble_seed option value must be an odd number > 0\n";
210          return ();          return ();
211      }      }
212    
# Line 225  Line 224 
224      my $persistance  = $options{ persistance } || 0;      my $persistance  = $options{ persistance } || 0;
225      if ( $persistance && ( $persistance <= 1 ) )      if ( $persistance && ( $persistance <= 1 ) )
226      {      {
227          print STDERR "proml::proml persistance option value must be > 1\n";          print STDERR "proml::proml() persistance option value must be > 1\n";
228          return ();          return ();
229      }      }
230    
# Line 245  Line 244 
244          }          }
245          elsif ( ref( $user_trees->[0] ) ne 'ARRAY' )  # First element not tree          elsif ( ref( $user_trees->[0] ) ne 'ARRAY' )  # First element not tree
246          {          {
247              print STDERR "proml::proml user_trees or rearrange option value must be reference to list of trees\n";              print STDERR "proml::proml() user_trees or rearrange option value must be reference to list of trees\n";
248              return ();              return ();
249          }          }
250      }      }
251    
252      my $weights      = $options{ weights };      my $weights      = $options{ weights };
253    
   
254      #---------------------------------------------------------------------------      #---------------------------------------------------------------------------
255      #  Options that are not proml options per se:      #  Options that are not proml options per se:
256      #---------------------------------------------------------------------------      #---------------------------------------------------------------------------
257    
258      my $program     = $options{ program } || 'proml';      my $program     = $options{ program } || 'proml';
259    
     my $tmp         = $options{ tmp };  
   
     my $tmp_dir     = $options{ tmp_dir };  
   
260      my $tree_format = $options{ tree_format } =~ m/overbeek/i ? 'overbeek'      my $tree_format = $options{ tree_format } =~ m/overbeek/i ? 'overbeek'
261                      : $options{ tree_format } =~ m/gjo/i      ? 'gjonewick'                      : $options{ tree_format } =~ m/gjo/i      ? 'gjonewick'
262                      : $options{ tree_format } =~ m/fig/i      ? 'fig'                      : $options{ tree_format } =~ m/fig/i      ? 'fig'
263                      :                                           'overbeek'; # Default                      :                                           'overbeek'; # Default
264    
265      my $save_tmp    = $tmp_dir && -d $tmp_dir;      my ( $tmp_dir, $save_tmp ) = temporary_directory( \%options );
     if ( $tmp_dir )  
     {  
         if ( -d $tmp_dir ) { $save_tmp = 1  }  
         else               { mkdir $tmp_dir }  
     }  
     else  
     {  
         $tmp = $tmp && -d  $tmp  ?  $tmp  
              :         -d '/tmp' ? '/tmp'  
              :                     '.';  
         my $int = int( 1000000000 * rand);  
         $tmp_dir = "$tmp/proml.$$.$int";  
         mkdir $tmp_dir;  
     }  
266    
267      #---------------------------------------------------------------------------      #---------------------------------------------------------------------------
268      #  Prepare data:      #  Prepare data:
# Line 434  Line 414 
414      #  Returned trees have our labels, and branch lengths that are in % change,      #  Returned trees have our labels, and branch lengths that are in % change,
415      #  not the more usual expected number per position:      #  not the more usual expected number per position:
416    
417      my @trees = map { gjonewicklib::newick_relabel_nodes( $_, \%id ) }      @trees = map { gjonewicklib::newick_relabel_nodes( $_, \%id ) } @trees;
                 @trees;  
418    
419      if ( $tree_format =~ m/overbeek/i )      if ( $tree_format =~ m/overbeek/i )
420      {      {
# Line 583  Line 562 
562  }  }
563    
564    
 sub min { $_[0] < $_[1] ? @_[0] : @_[1] }  
   
   
565  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
566  #  Auxiliary functions:  #  Auxiliary functions:
567  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
568    
569    sub min { $_[0] < $_[1] ? $_[0] : $_[1] }
570    
571    
572  sub write_infile  sub write_infile
573  {  {
574      open( INFILE, '>infile' ) or return 0;      open( INFILE, '>infile' ) or return 0;
# Line 637  Line 616 
616  }  }
617    
618    
619    #-------------------------------------------------------------------------------
620    #  The SEED has things in special places.  Be aware of them if running SEED.
621    #-------------------------------------------------------------------------------
622    
623    my $tmp;        #  The default place for temp files or directories
624    my $ext_bin;    #  FIG path to external binaries
625    
626    eval { require FIG_Config;
627           $tmp     = $FIG_Config::temp;
628           $ext_bin = $FIG_Config::ext_bin;
629         };
630    
631    
632    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
633    #  $program = executable( $program, \%options )
634    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
635    sub executable
636    {
637        my ( $program, $options ) = @_;
638        return undef if ! $program;
639    
640        $options ||= {};
641    
642        return $options->{ $program } ? $options->{ $program } # explicit?
643             : $ext_bin               ? "$ext_bin/$program"    # SEED?
644             :                          $program;
645    }
646    
647    
648    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
649    #  Find or create a temporary directory.
650    #  If it does not exist, create it.  If it exists, mark it for saving.
651    #
652    #    $tmp_dir              = temporary_directory( \%options )
653    #  ( $tmp_dir, $save_tmp ) = temporary_directory( \%options )
654    #
655    #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
656    
657    sub temporary_directory
658    {
659        my $options = shift || {};
660    
661        my $tmp_dir  = $options->{ tmpdir }  || $options->{ tmp_dir };
662        my $save_tmp = $options->{ savetmp } || $options->{ save_tmp } || '';
663    
664        if ( $tmp_dir )
665        {
666            if ( -d $tmp_dir ) { $options->{ savetmp } = $save_tmp = 1 }
667        }
668        else
669        {
670            if ( $options->{ tmp }  && -d  $options->{ tmp } )
671            {
672                $tmp = $options->{ tmp };
673            }
674            elsif ( ! $tmp || ! -d $tmp )
675            {
676                $options->{ tmp } = $tmp = -d '/tmp' ? '/tmp' : '.';
677            }
678    
679            $tmp_dir = sprintf( "$tmp/" . __PACKAGE__ . "_tmp.%05d.%09d", $$, int(1000000000*rand) );
680            $options->{ tmpdir } = $tmp_dir;
681        }
682    
683        if ( $tmp_dir && ! -d $tmp_dir )
684        {
685            mkdir $tmp_dir;
686            if ( ! -d $tmp_dir )
687            {
688                print STDERR __PACKAGE__ . "::temporary_directory could not create '$tmp_dir'\n";
689                $options->{ tmpdir } = $tmp_dir = undef;
690            }
691        }
692    
693        return wantarray ? ( $tmp_dir, $save_tmp ) : $tmp_dir;
694    }
695    
696    
697  1;  1;

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3