File Coverage

blib/lib/Bio/Phylo/Models/Substitution/Dna.pm
Criterion Covered Total %
statement 89 283 31.4
branch 14 108 12.9
condition 1 42 2.3
subroutine 22 38 57.8
pod 24 24 100.0
total 150 495 30.3


line stmt bran cond sub pod time code
1             package Bio::Phylo::Models::Substitution::Dna;
2 14     14   64399 use Bio::Phylo::Util::CONSTANT qw'/looks_like/ :objecttypes';
  14         29  
  14         3420  
3 14     14   100 use Bio::Phylo::Util::Exceptions qw'throw';
  14         29  
  14         634  
4 14     14   360 use Bio::Phylo::IO qw(parse unparse);
  14         31  
  14         634  
5 14     14   75 use Bio::Phylo::Util::Logger':levels';
  14         28  
  14         1427  
6 14     14   6611 use File::Temp qw(tempfile cleanup);
  14         115391  
  14         874  
7              
8 14     14   104 use strict;
  14         28  
  14         267  
9 14     14   65 use warnings;
  14         29  
  14         33148  
10              
11 0     0   0 sub _INDEX_OF_ { { A => 0, C => 1, G => 2, T => 3 } }
12 0     0   0 sub _BASE_AT_ { [qw(A C G T)] }
13              
14             my $logger = Bio::Phylo::Util::Logger->new;
15              
16             =head1 NAME
17              
18             Bio::Phylo::Models::Substitution::Dna - DNA substitution model
19              
20             =head1 SYNOPSIS
21              
22             use Bio::Phylo::Models::Substitution::Dna;
23              
24             # create a DNA substitution model from scratch
25             my $model = Bio::Phylo::Models::Substitution::Dna->new(
26             '-type' => 'GTR',
27             '-pi' => [ 0.23, 0.27, 0.24, 0.26 ],
28             '-kappa' => 2,
29             '-alpha' => 0.9,
30             '-pinvar' => 0.5,
31             '-ncat' => 6,
32             '-median' => 1,
33             '-rate' => [
34             [ 0.23, 0.23, 0.23, 0.23 ],
35             [ 0.23, 0.26, 0.26, 0.26 ],
36             [ 0.27, 0.26, 0.26, 0.26 ],
37             [ 0.24, 0.26, 0.26, 0.26 ]
38             ]
39             );
40              
41             # get substitution rate from A to C
42             my $rate = $model->get_rate('A', 'C');
43              
44             # get model representation that can be used by Garli
45             my $modelstr = $model->to_string( '-format' => 'garli' )
46              
47             =head1 DESCRIPTION
48              
49             This is a superclass for models of DNA evolution. Classes that inherit from this
50             class provide methods for retreiving general parameters such as substitution rates
51             or the number of states as well as model-specific parameters. Currently most of the
52             popular models are implemented. The static function C<modeltest> determines the
53             substitution model from a L<Bio::Phylo::Matrices::Matrix> object and returns the
54             appropriate instance of the subclass. This class also provides serialization
55             of a model to standard phylogenetics file formats.
56              
57             =head1 METHODS
58              
59             =head2 CONSTRUCTOR
60              
61             =over
62              
63             =item new
64              
65             Dna model constructor.
66              
67             Type : Constructor
68             Title : new
69             Usage : my $model = Bio::Phylo::Models::Substitution::Dna->new(%args);
70             Function: Instantiates a Bio::Phylo::Models::Substitution::Dna object.
71             Returns : A Bio::Phylo::Models::Substitution::Dna object.
72             Args : Optional:
73             -type => type of model, one of GTR, F81, HKY85, JC69, K80
74             -pi => base frequencies of bases A, C, G, T
75             -kappa => ratio transitions/transversions
76             -alpha => shape parameter (for models of GTR family)
77             -mu => overall mutation rate
78             -pinvar => proportion of invariant sites
79             -ncat => number of distinct rate categories
80             -median => median for gamma-modeled rate categories
81             -rate => Array of Arrays (4x4) giving substitution rates betwen A, C, T, G
82             -catweights => weights for rate categories
83             =cut
84              
85             sub new {
86 1     1 1 968 my $class = shift;
87 1         5 my %args = looks_like_hash @_;
88 1 50       7 $class .= '::' . uc $args{'-type'} if $args{'-type'};
89 1         2 delete $args{'-type'};
90 1         2 my $self = {};
91 1         3 bless $self, looks_like_class $class;
92 1         7 while ( my ( $key, $value ) = each %args ) {
93 7         26 $key =~ s/^-/set_/;
94 7         32 $self->$key($value);
95             }
96 1         4 return $self;
97             }
98              
99             =item get_catrates
100              
101             Getter for rate categories, implemented by child classes.
102              
103             Type : method
104             Title : get_catrates
105             Usage : $model->get_catrates;
106             Function: Getter for rate categories.
107             Returns : scalar or array
108             Args : None.
109              
110             =cut
111              
112             sub get_catrates {
113 0     0 1 0 throw 'NotImplemented' => 'FIXME';
114             }
115              
116             =item get_nst
117              
118             Getter for number of transition rate parameters.
119              
120             Type : method
121             Title : get_nst
122             Usage : $model->get_nst;
123             Function: Getter for number of transition rate parameters.
124             Returns : scalar
125             Args : None.
126              
127             =cut
128              
129 0     0 1 0 sub get_nst { 6 }
130              
131             =item get_rate
132              
133             Getter for substitution rate. If bases are given as arguments,
134             returns corresponding rate. If no arguments given, returns rate matrix or
135             overall rate, dependent on model.
136              
137             Type : method
138             Title : get_rate
139             Usage : $model->get_rate('A', 'C');
140             Function: Getter for transition rate between nucleotides.
141             Returns : scalar or array
142             Args : Optional:
143             base1: scalar
144             base2: scalar
145             =cut
146              
147             sub get_rate {
148 0     0 1 0 my $self = shift;
149 0 0       0 if (@_) {
150 0         0 my $src = _INDEX_OF_()->{ uc shift };
151 0         0 my $target = _INDEX_OF_()->{ uc shift };
152 0 0       0 $self->{'_rate'} = [] if not $self->{'_rate'};
153 0 0       0 if ( not $self->{'_rate'}->[$src] ) {
154 0         0 $self->{'_rate'}->[$src] = [];
155             }
156 0         0 return $self->{'_rate'}->[$src]->[$target];
157             }
158             else {
159 0         0 return $self->{'_rate'};
160             }
161             }
162              
163             =item get_nstates
164              
165             Getter for number of states (bases).
166              
167             Type : method
168             Title : get_nstates
169             Usage : $model->get_nstates;
170             Function: Getter for transition rate between nucleotides.
171             Returns : scalar
172             Args : None
173              
174             =cut
175              
176             sub get_nstates {
177 0     0 1 0 my $states = _BASE_AT_;
178 0         0 return scalar @{ $states };
  0         0  
179             }
180              
181             =item get_ncat
182              
183             Getter for number of rate categories.
184              
185             Type : method
186             Title : get_ncat
187             Usage : $model->get_ncat;
188             Function: Getter for number of rate categories.
189             Returns : scalar
190             Args : None
191              
192             =cut
193              
194 2     2 1 8 sub get_ncat { shift->{'_ncat'} }
195              
196             =item get_catweights
197              
198             Getter for weights on rate categories.
199              
200             Type : method
201             Title : get_catweights
202             Usage : $model->get_catweights;
203             Function: Getter for number of rate categories.
204             Returns : array
205             Args : None
206              
207             =cut
208              
209 0     0 1 0 sub get_catweights { shift->{'_catweights'} }
210              
211             =item get_kappa
212              
213             Getter for transition/transversion ratio.
214              
215             Type : method
216             Title : get_kappa
217             Usage : $model->get_kappa;
218             Function: Getter for transition/transversion ratio.
219             Returns : scalar
220             Args : None
221              
222             =cut
223              
224 1     1 1 5 sub get_kappa { shift->{'_kappa'} }
225              
226             =item get_alpha
227              
228             Getter for shape parameter.
229              
230             Type : method
231             Title : get_alpha
232             Usage : $model->get_alpha;
233             Function: Getter for shape parameter.
234             Returns : scalar
235             Args : None
236              
237             =cut
238              
239 2     2 1 13 sub get_alpha { shift->{'_alpha'} }
240              
241             =item get_mu
242              
243             Getter for overall mutation rate.
244              
245             Type : method
246             Title : get_mu
247             Usage : $model->get_mu;
248             Function: Getter for overall mutation rate.
249             Returns : scalar
250             Args : None
251              
252             =cut
253              
254 0     0 1 0 sub get_mu { shift->{'_mu'} }
255              
256             =item get_pinvar
257              
258             Getter for proportion of invariant sites.
259              
260             Type : method
261             Title : get_pinvar
262             Usage : $model->get_pinvar;
263             Function: Getter for proportion of invariant sites.
264             Returns : scalar
265             Args : None
266              
267             =cut
268              
269 2     2 1 7 sub get_pinvar { shift->{'_pinvar'} }
270              
271             =item get_pi
272              
273             Getter for base frequencies.
274              
275             Type : method
276             Title : get_pi
277             Usage : $model->get_pi;
278             Function: Getter for base frequencies.
279             Returns : array
280             Args : Optional:
281             Base (A, C, T or G)
282              
283             =cut
284              
285             sub get_pi {
286 0     0 1 0 my $self = shift;
287 0 0       0 $self->{'_pi'} = [] if not $self->{'_pi'};
288 0 0       0 if (@_) {
289 0         0 my $base = uc shift;
290 0         0 return $self->{'_pi'}->[ _INDEX_OF_()->{$base} ];
291             }
292             else {
293 0         0 return $self->{'_pi'};
294             }
295             }
296              
297             =item get_median
298              
299             Getter for median for gamma-modeled rate categories.
300              
301             Type : method
302             Title : get_median
303             Usage : $model->get_median;
304             Function: Getter for median.
305             Returns : scalar
306             Args : None
307              
308             =cut
309              
310 1     1 1 4 sub get_median { shift->{'_median'} }
311              
312             =item set_rate
313              
314             Setter for substitution rate.
315              
316             Type : method
317             Title : set_rate
318             Usage : $model->set_rate(1);
319             Function: Set nucleotide transition rates.
320             Returns : A Bio::Phylo::Models::Substitution::Dna object.
321             Args : scalar or array of arrays (4x4)
322              
323             =cut
324              
325             sub set_rate {
326 1     1 1 3 my ( $self, $q ) = @_;
327 1 50       3 ref $q eq 'ARRAY' or throw 'BadArgs' => 'Not an array ref!';
328 1 50       2 scalar @{$q} == 4 or throw 'BadArgs' => 'Q matrix must be 4 x 4';
  1         3  
329 1         2 for my $row ( @{$q} ) {
  1         3  
330 4 50       5 scalar @{$row} == 4 or throw 'BadArgs' => 'Q matrix must be 4 x 4';
  4         8  
331             }
332 1         3 $self->{'_rate'} = $q;
333 1         3 return $self;
334             }
335              
336             =item set_ncat
337              
338             Setter for number of rate categories.
339              
340             Type : method
341             Title : set_ncat
342             Usage : $model->set_ncat(6);
343             Function: Set the number of rate categoeries.
344             Returns : A Bio::Phylo::Models::Substitution::Dna object.
345             Args : scalar
346              
347             =cut
348              
349             sub set_ncat {
350 1     1 1 1 my $self = shift;
351 1         2 $self->{'_ncat'} = shift;
352 1         4 return $self;
353             }
354              
355             =item set_catweights
356              
357             Setter for weights on rate categories.
358              
359             Type : method
360             Title : set_catweights
361             Usage : $model->get_catweights;
362             Function: Set number of rate categories.
363             Returns : A Bio::Phylo::Models::Substitution::Dna object.
364             Args : array
365              
366             =cut
367              
368             sub set_catweights {
369 0     0 1 0 my $self = shift;
370 0         0 $self->{'_catweights'} = shift;
371 0         0 return $self;
372             }
373              
374             =item set_kappa
375              
376             Setter for weights on rate categories.
377              
378             Type : method
379             Title : set_kappa
380             Usage : $model->set_kappa(2);
381             Function: Set transition/transversion ratio.
382             Returns : A Bio::Phylo::Models::Substitution::Dna object.
383             Args : scalar
384              
385             =cut
386              
387             sub set_kappa {
388 1     1 1 3 my $self = shift;
389 1         3 $self->{'_kappa'} = shift;
390 1         3 return $self;
391             }
392              
393             =item set_alpha
394              
395             Setter for shape parameter.
396              
397             Type : method
398             Title : set_alpha
399             Usage : $model->set_alpha(1);
400             Function: Set shape parameter.
401             Returns : A Bio::Phylo::Models::Substitution::Dna object.
402             Args : scalar
403              
404             =cut
405              
406             sub set_alpha {
407 1     1 1 2 my $self = shift;
408 1         4 $self->{'_alpha'} = shift;
409 1         3 return $self;
410             }
411              
412             =item set_mu
413              
414             Setter for overall mutation rate.
415              
416             Type : method
417             Title : set_mu
418             Usage : $model->set_mu(0.5);
419             Function: Set overall mutation rate.
420             Returns : A Bio::Phylo::Models::Substitution::Dna object.
421             Args : scalar
422              
423             =cut
424              
425             sub set_mu {
426 0     0 1 0 my $self = shift;
427 0         0 $self->{'_mu'} = shift;
428 0         0 return $self;
429             }
430              
431             =item set_pinvar
432              
433             Set for proportion of invariant sites.
434              
435             Type : method
436             Title : set_pinvar
437             Usage : $model->set_pinvar(0.1);
438             Function: Set proportion of invariant sites.
439             Returns : A Bio::Phylo::Models::Substitution::Dna object.
440             Args : scalar
441              
442             =cut
443              
444             sub set_pinvar {
445 1     1 1 4 my $self = shift;
446 1         3 my $pinvar = shift;
447 1 50 33     13 if ( $pinvar <= 0 || $pinvar >= 1 ) {
448 0         0 throw 'BadArgs' => "Pinvar not between 0 and 1";
449             }
450 1         11 $self->{'_pinvar'} = $pinvar;
451 1         9 return $self;
452             }
453              
454             =item set_pi
455              
456             Setter for base frequencies.
457              
458             Type : method
459             Title : get_pi
460             Usage : $model->set_pi((0.2, 0.2, 0.3, 0.3));
461             Function: Set base frequencies.
462             Returns : A Bio::Phylo::Models::Substitution::Dna object.
463             Args : array of four base frequencies (A, C, G, T)
464             Comments: Base frequencies must sum to one
465              
466             =cut
467              
468             sub set_pi {
469 1     1 1 4 my ( $self, $pi ) = @_;
470 1 50       4 ref $pi eq 'ARRAY' or throw 'BadArgs' => "Not an array ref!";
471 1         2 my $total = 0;
472 1         2 $total += $_ for @{$pi};
  1         4  
473 1         3 my $epsilon = 0.000001;
474 1 50       4 abs(1 - $total) < $epsilon or throw 'BadArgs' => 'Frequencies must sum to one';
475 1         2 $self->{'_pi'} = $pi;
476 1         3 return $self;
477             }
478              
479             =item set_median
480              
481             Setter for median for gamma-modeled rate categories.
482              
483             Type : method
484             Title : set_median
485             Usage : $model->set_median(1);
486             Function: Setter for median.
487             Returns : A Bio::Phylo::Models::Substitution::Dna object.
488             Args : scalar
489              
490             =cut
491              
492             sub set_median {
493 1     1 1 2 my $self = shift;
494 1         3 $self->{'_median'} = !!shift;
495 1         3 return $self;
496             }
497              
498             =item modeltest
499              
500             Performing a modeltest using the package 'phangorn' in
501             R (Schliep, Bioinformatics (2011) 27 (4): 592-593) from an
502             DNA alignment. If no tree is given as argument, a neighbor-joining
503             tree is generated from the alignment to perform model testing.
504             Selects the model with the minimum AIC.
505              
506             Type : method
507             Title : modeltest
508             Usage : $model->modeltest(-matrix=>$matrix);
509             Function: Determine DNA substitution model from alignment.
510             Returns : An object which is subclass of Bio::Phylo::Models::Substitution::Dna.
511             Args : -matrix: A Bio::Phylo::Matrices::Matrix object
512             Optional:
513             -tree: A Bio::Phylo::Forest::Tree object
514             -timeout: Timeout in seconds to prevent getting stuck in an R process.
515             Comments: Prerequisites: Statistics::R, R, and the R package phangorn.
516              
517             =cut
518              
519             sub modeltest {
520 0     0 1 0 my ($self, %args) = @_;
521              
522 0         0 my $matrix = $args{'-matrix'};
523 0         0 my $tree = $args{'-tree'};
524 0         0 my $timeout = $args{'-timeout'};
525              
526 0         0 my $model;
527              
528 0 0       0 if ( looks_like_class 'Statistics::R' ) {
529              
530 0         0 eval {
531             # phangorn needs files as input
532 0         0 my ($fasta_fh, $fasta) = tempfile();
533 0         0 print $fasta_fh unparse('-phylo'=>$matrix, '-format'=>'fasta');
534 0         0 close $fasta_fh;
535              
536             # instanciate R and lcheck if phangorn is installed
537 0         0 my $R = Statistics::R->new;
538 0 0       0 $R->timeout($timeout) if $timeout;
539 0         0 $R->run(q[options(device=NULL)]);
540 0         0 $R->run(q[package <- require("phangorn")]);
541              
542 0 0       0 if ( ! $R->get(q[package]) eq "TRUE") {
543 0         0 $logger->warn("R library phangorn must be installed to run modeltest");
544 0         0 return $model;
545             }
546              
547             # read data
548 0         0 $R->run(qq[data <- read.FASTA("$fasta")]);
549              
550             # remove temp file
551 0         0 cleanup();
552              
553 0 0       0 if ( $tree ) {
554             # make copy of tree since it will be pruned
555 0         0 my $current_tree = parse('-format'=>'newick', '-string'=>$tree->to_newick)->first;
556             # prune out taxa from tree that are not present in the data
557 0         0 my @taxon_names = map {$_->get_name} @{ $matrix->get_entities };
  0         0  
  0         0  
558 0         0 $logger->debug('pruning input tree');
559 0         0 $current_tree->keep_tips(\@taxon_names);
560 0         0 $logger->debug('pruned input tree: ' . $current_tree->to_newick);
561              
562 0 0 0     0 if ( ! $current_tree or scalar( @{ $current_tree->get_terminals } ) < 3 ) {
  0         0  
563 0         0 $logger->warn('pruned tree has too few tip labels, determining substitution model using NJ tree');
564 0         0 $R->run(q[test <- modelTest(phyDat(data))]);
565             }
566             else {
567 0         0 my $newick = $current_tree->to_newick;
568              
569 0         0 $R->run(qq[tree <- read.tree(text="$newick")]);
570             # call modelTest
571 0         0 $logger->debug("calling modelTest from R package phangorn");
572 0         0 $R->run(q[test <- modelTest(phyDat(data), tree=tree)]);
573             }
574             }
575             else {
576             # modelTest will estimate tree
577 0         0 $R->run(q[test <- modelTest(phyDat(data))]);
578             }
579              
580             # get model with lowest Aikaike information criterion
581 0         0 $R->run(q[model <- test[which(test$AIC==min(test$AIC)),]$Model]);
582 0         0 my $modeltype = $R->get(q[model]);
583 0         0 $logger->info("estimated DNA evolution model $modeltype");
584              
585             # determine model parameters
586 0         0 $R->run(q[env <- attr(test, "env")]);
587 0         0 $R->run(q[fit <- eval(get(model, env), env)]);
588              
589             # get base freqs
590 0         0 my $pi = $R->get(q[fit$bf]);
591              
592             # get overall mutation rate
593 0         0 my $mu = $R->get(q[fit$rate]);
594              
595             # get lower triangle of rate matrix (column order ACGT)
596             # and fill whole matrix; set diagonal values to 1
597 0         0 my $q = $R->get(q[fit$Q]);
598 0         0 my $rate_matrix = [ [ 1, $q->[0], $q->[1], $q->[3] ],
599             [ $q->[0], 1, $q->[2], $q->[4] ],
600             [ $q->[1], $q->[2], 1, $q->[5] ],
601             [ $q->[3], $q->[4], $q->[5], 1 ]
602             ];
603              
604             # create model with specific parameters dependent on primary model type
605 0 0       0 if ( $modeltype =~ /JC/ ) {
    0          
    0          
    0          
    0          
606 0         0 require Bio::Phylo::Models::Substitution::Dna::JC69;
607 0         0 $model = Bio::Phylo::Models::Substitution::Dna::JC69->new();
608             }
609             elsif ( $modeltype =~ /F81/ ) {
610 0         0 require Bio::Phylo::Models::Substitution::Dna::F81;
611 0         0 $model = Bio::Phylo::Models::Substitution::Dna::F81->new('-pi' => $pi);
612             }
613             elsif ( $modeltype =~ /GTR/ ) {
614 0         0 require Bio::Phylo::Models::Substitution::Dna::GTR;
615 0         0 $model = Bio::Phylo::Models::Substitution::Dna::GTR->new('-pi' => $pi);
616             }
617             elsif ( $modeltype =~ /HKY/ ) {
618 0         0 require Bio::Phylo::Models::Substitution::Dna::HKY85;
619             # transition/transversion ratio kappa determined by transiton A->G/A->C in Q matrix
620 0         0 my $kappa = $R->get(q[fit$Q[2]/fit$Q[1]]);
621 0         0 $model = Bio::Phylo::Models::Substitution::Dna::HKY85->new('-kappa' => $kappa, '-pi' => $pi );
622             }
623             elsif ( $modeltype =~ /K80/ ) {
624 0         0 require Bio::Phylo::Models::Substitution::Dna::K80;
625 0         0 my $kappa = $R->get(q[fit$Q[2]]);
626 0         0 $model = Bio::Phylo::Models::Substitution::Dna::K80->new(
627             '-pi' => $pi,
628             '-kappa' => $kappa );
629             }
630             # Model is unknown (e.g. phangorn's SYM ?)
631             else {
632 0         0 $logger->debug("unknown model type, setting to generic DNA substitution model");
633 0         0 $model = Bio::Phylo::Models::Substitution::Dna->new(
634             '-pi' => $pi );
635             }
636              
637             # set gamma parameters
638 0 0       0 if ( $modeltype =~ /\+G/ ) {
639 0         0 $logger->debug("setting gamma parameters for $modeltype model");
640             # shape of gamma distribution
641 0         0 my $alpha = $R->get(q[fit$shape]);
642 0         0 $model->set_alpha($alpha);
643             # number of categories for Gamma distribution
644 0         0 my $ncat = $R->get(q[fit$k]);
645 0         0 $model->set_ncat($ncat);
646             # weights for rate categories
647 0         0 my $catweights = $R->get(q[fit$w]);
648 0         0 $model->set_catweights($catweights);
649             }
650              
651             # set invariant parameters
652 0 0       0 if ( $modeltype =~ /\+I/ ) {
653 0         0 $logger->debug("setting invariant site parameters for $modeltype model");
654             # get proportion of invariant sites
655 0         0 my $pinvar = $R->get(q[fit$inv]);
656 0         0 $model->set_pinvar($pinvar);
657             }
658             # set universal parameters
659 0         0 $model->set_rate($rate_matrix);
660 0         0 $model->set_mu($mu);
661             };
662             # catch possible R errors (e.g. timeout)
663 0 0       0 if ($@) {
664 0         0 $logger->warn("modeltest not successful : " . $@);
665             }
666             }
667             else {
668 0         0 $logger->warn("Statistics::R must be installed to run modeltest");
669             }
670              
671 0         0 return $model;
672             }
673              
674             =item to_string
675              
676             Get string representation of model in specified format
677             (paup, phyml, mrbayes or garli)
678              
679             Type : method
680             Title : to_string
681             Usage : $model->to_string(-format=>'mrbayes');
682             Function: Write model to string.
683             Returns : scalar
684             Args : scalar
685             Comments: format must be either paup, phyml, mrbayes or garli
686              
687             =cut
688              
689             sub to_string {
690 1     1 1 2 my $self = shift;
691 1         4 my %args = looks_like_hash @_;
692 1 50       7 if ( $args{'-format'} =~ m/paup/i ) {
693 0         0 return $self->_to_paup_string(@_);
694             }
695 1 50       3 if ( $args{'-format'} =~ m/phyml/i ) {
696 0         0 return $self->_to_phyml_string(@_);
697             }
698 1 50       3 if ( $args{'-format'} =~ m/mrbayes/i ) {
699 0         0 return $self->_to_mrbayes_string(@_);
700             }
701 1 50       6 if ( $args{'-format'} =~ m/garli/i ) {
702 1         5 return $self->_to_garli_string(@_);
703             }
704             }
705              
706             sub _to_garli_string {
707 1     1   2 my $self = shift;
708 1         4 my $nst = $self->get_nst;
709 1         4 my $string = "ratematrix ${nst}\n";
710 1 50       3 if ( my $pinvar = $self->get_pinvar ) {
711 1         2 $string .= "invariantsites fixed\n";
712             }
713 1 50       2 if ( my $ncat = $self->get_ncat ) {
714 1         3 $string .= "numratecats ${ncat}\n";
715             }
716 1 50       2 if ( my $alpha = $self->get_alpha ) {
717 1         2 $string .= "ratehetmodel gamma\n";
718             }
719 1         3 return $string;
720             }
721              
722             sub _to_mrbayes_string {
723 0     0     my $self = shift;
724 0           my $string = 'lset ';
725 0           $string .= ' nst=' . $self->get_nst;
726 0 0 0       if ( $self->get_pinvar && $self->get_alpha ) {
    0          
    0          
727 0           $string .= ' rates=invgamma';
728 0 0         if ( $self->get_ncat ) {
729 0           $string .= ' ngammacat=' . $self->get_ncat;
730             }
731             }
732             elsif ( $self->get_pinvar ) {
733 0           $string .= ' rates=propinv';
734             }
735             elsif ( $self->get_alpha ) {
736 0           $string .= ' rates=gamma';
737 0 0         if ( $self->get_ncat ) {
738 0           $string .= ' ngammacat=' . $self->get_ncat;
739             }
740             }
741 0           $string .= ";\n";
742 0 0 0       if ( $self->get_kappa && $self->get_nst == 2 ) {
743 0           $string .= 'prset tratiopr=fixed(' . $self->get_kappa . ");\n";
744             }
745 0           my @rates;
746 0           push @rates, $self->get_rate( 'A' => 'C' );
747 0           push @rates, $self->get_rate( 'A' => 'G' );
748 0           push @rates, $self->get_rate( 'A' => 'T' );
749 0           push @rates, $self->get_rate( 'C' => 'G' );
750 0           push @rates, $self->get_rate( 'C' => 'T' );
751 0           push @rates, $self->get_rate( 'G' => 'T' );
752 0           $string .= 'prset revmatpr=fixed(' . join( ',', @rates ) . ");\n";
753              
754 0 0 0       if ( $self->get_pi('A')
      0        
      0        
755             && $self->get_pi('C')
756             && $self->get_pi('G')
757             && $self->get_pi('T') )
758             {
759 0           my @freqs;
760 0           push @freqs, $self->get_pi('A');
761 0           push @freqs, $self->get_pi('C');
762 0           push @freqs, $self->get_pi('G');
763 0           push @freqs, $self->get_pi('T');
764 0           $string .= 'prset statefreqpr=fixed(' . join( ',', @freqs ) . ");\n";
765             }
766 0 0         if ( $self->get_alpha ) {
767 0           $string .= 'prset shapepr=fixed(' . $self->get_alpha . ");\n";
768             }
769 0 0         if ( $self->get_pinvar ) {
770 0           $string .= 'prset pinvarpr=fixed(' . $self->get_pinvar . ");\n";
771             }
772             }
773              
774             sub _to_phyml_string {
775 0     0     my $self = shift;
776 0           my $m = ref $self;
777 0           $m =~ s/.+://;
778 0           my $string = "--model $m";
779 0 0 0       if ( $self->get_pi('A')
      0        
      0        
780             && $self->get_pi('C')
781             && $self->get_pi('G')
782             && $self->get_pi('T') )
783             {
784 0           my @freqs;
785 0           push @freqs, $self->get_pi('A');
786 0           push @freqs, $self->get_pi('C');
787 0           push @freqs, $self->get_pi('G');
788 0           push @freqs, $self->get_pi('T');
789 0           $string .= ' -f ' . join ' ', @freqs;
790             }
791 0 0 0       if ( $self->get_nst == 2 and defined( my $kappa = $self->get_kappa ) ) {
792 0           $string .= ' --ts/tv ' . $kappa;
793             }
794 0 0         if ( $self->get_pinvar ) {
795 0           $string .= ' --pinv ' . $self->get_pinvar;
796             }
797 0 0         if ( $self->get_ncat ) {
798 0           $string .= ' --nclasses ' . $self->get_ncat;
799 0 0         $string .= ' --use_median' if $self->get_median;
800             }
801 0 0         if ( $self->get_alpha ) {
802 0           $string .= ' --alpha ' . $self->get_alpha;
803             }
804 0           return $string;
805             }
806              
807             sub _to_paup_string {
808 0     0     my $self = shift;
809 0           my $nst = $self->get_nst;
810 0           my $string = 'lset nst=' . $nst;
811 0 0 0       if ( $nst == 2 and defined( my $kappa = $self->get_kappa ) ) {
812 0           $string .= ' tratio=' . $kappa;
813             }
814 0 0         if ( $nst == 6 ) {
815 0           my @rates;
816 0           push @rates, $self->get_rate( 'A' => 'C' );
817 0           push @rates, $self->get_rate( 'A' => 'G' );
818 0           push @rates, $self->get_rate( 'A' => 'T' );
819 0           push @rates, $self->get_rate( 'C' => 'G' );
820 0           push @rates, $self->get_rate( 'C' => 'T' );
821 0           $string .= ' rmatrix=(' . join( ' ', @rates ) . ')';
822             }
823 0 0 0       if ( $self->get_pi('A') && $self->get_pi('C') && $self->get_pi('G') ) {
      0        
824 0           my @freqs;
825 0           push @freqs, $self->get_pi('A');
826 0           push @freqs, $self->get_pi('C');
827 0           push @freqs, $self->get_pi('G');
828 0           $string .= ' basefreq=(' . join( ' ', @freqs ) . ')';
829             }
830 0 0         if ( $self->get_alpha ) {
831 0           $string .= ' rates=gamma shape=' . $self->get_alpha;
832             }
833 0 0         if ( $self->get_ncat ) {
834 0           $string .= ' ncat=' . $self->get_ncat;
835 0 0         $string .= ' reprate=' . ( $self->get_median ? 'median' : 'mean' );
836             }
837 0 0         if ( $self->get_pinvar ) {
838 0           $string .= ' pinvar=' . $self->get_pinvar;
839             }
840 0           return $string . ';';
841             }
842              
843 0     0     sub _type { _MODEL_ }
844              
845             =back
846              
847             =head1 SEE ALSO
848              
849             There is a mailing list at L<https://groups.google.com/forum/#!forum/bio-phylo>
850             for any user or developer questions and discussions.
851              
852             =over
853              
854             =item L<Bio::Phylo::Manual>
855              
856             Also see the manual: L<Bio::Phylo::Manual> and L<http://rutgervos.blogspot.com>.
857              
858             =back
859              
860             =head1 CITATION
861              
862             If you use Bio::Phylo in published research, please cite it:
863              
864             B<Rutger A Vos>, B<Jason Caravas>, B<Klaas Hartmann>, B<Mark A Jensen>
865             and B<Chase Miller>, 2011. Bio::Phylo - phyloinformatic analysis using Perl.
866             I<BMC Bioinformatics> B<12>:63.
867             L<http://dx.doi.org/10.1186/1471-2105-12-63>
868              
869             =cut
870              
871             1;