t/AlignIO/AlignIO.t: fix number of tests in plan (fixup c523e6bed866)
[bioperl-live.git] / Bio / Variation / AAReverseMutate.pm
blob13cf1b76d40febad4046877fbe63f58026923ccc
2 # BioPerl module for Bio::Variation::AAReverseMutate
4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
6 # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org>
8 # Copyright Heikki Lehvaslaiho
10 # You may distribute this module under the same terms as perl itself
12 # POD documentation - main docs before the code
14 =head1 NAME
16 Bio::Variation::AAReverseMutate - point mutation and codon
17 information from single amino acid changes
19 =head1 SYNOPSIS
21 $aamut = Bio::Variation::AAReverseMutate->new
22 (-aa_ori => 'F',
23 -aa_mut => 'S',
24 -codon_ori => 'ttc', # optional
25 -codon_table => '3' # defaults to 1
28 @points = $aamut->each_Variant;
30 if (scalar @points > 0 ) {
31 foreach $rnachange ( @points ) {
32 # $rnachange is a Bio::Variation::RNAChange object
33 print " ", $rnachange->allele_ori->seq, ">",
34 $rnachange->allele_mut->seq, " in ",
35 $rnachange->codon_ori, ">", $rnachange->codon_mut,
36 " at position ", $rnachange->codon_pos, "\n";
38 } else {
39 print "No point mutations possible\n",
42 =head1 DESCRIPTION
44 Bio::Variation::AAReverseMutate objects take in reference and mutated
45 amino acid information and deduces potential point mutations at RNA
46 level leading to this change. The choice can be further limited by
47 letting the object know what is the the codon in the reference
48 sequence. The results are returned as L<Bio::Variation::RNAChange>
49 objects.
51 =head1 FEEDBACK
53 =head2 Mailing Lists
55 User feedback is an integral part of the evolution of this and other
56 Bioperl modules. Send your comments and suggestions preferably to the
57 Bioperl mailing lists Your participation is much appreciated.
59 bioperl-l@bioperl.org - General discussion
60 http://bioperl.org/wiki/Mailing_lists - About the mailing lists
62 =head2 Support
64 Please direct usage questions or support issues to the mailing list:
66 I<bioperl-l@bioperl.org>
68 rather than to the module maintainer directly. Many experienced and
69 reponsive experts will be able look at the problem and quickly
70 address it. Please include a thorough description of the problem
71 with code and data examples if at all possible.
73 =head2 Reporting Bugs
75 Report bugs to the Bioperl bug tracking system to help us keep track
76 the bugs and their resolution. Bug reports can be submitted via the
77 web:
79 https://github.com/bioperl/bioperl-live/issues
81 =head1 AUTHOR - Heikki Lehvaslaiho
83 Email: heikki-at-bioperl-dot-org
85 =head1 APPENDIX
87 The rest of the documentation details each of the object
88 methods. Internal methods are usually preceded with a _
90 =cut
93 # Let the code begin...
95 package Bio::Variation::AAReverseMutate;
97 use strict;
99 # Object preamble - inheritance
100 use Bio::Tools::CodonTable;
101 use Bio::Variation::RNAChange;
102 use Bio::Variation::Allele;
104 use base qw(Bio::Root::Root);
106 sub new {
107 my($class,@args) = @_;
108 my $self = $class->SUPER::new(@args);
110 my ($aa_ori, $aa_mut, $codon_ori, $codon_table) =
111 $self->_rearrange([qw(AA_ORI
112 AA_MUT
113 CODON
114 CODON_TABLE
115 )],@args);
117 $aa_ori && $self->aa_ori($aa_ori);
118 $aa_mut && $self->aa_mut($aa_mut);
119 $codon_ori && $self->codon_ori($codon_ori);
120 $codon_table && $self->codon_table($codon_table);
122 return $self; # success - we hope!
127 =head2 aa_ori
129 Title : aa_ori
130 Usage : $obj->aa_ori();
131 Function:
133 Sets and returns original aa sequence. If value is not
134 set, returns false.
136 Amino acid sequences are stored in upper case characters,
137 others in lower case.
139 Example :
140 Returns : string
141 Args : single character amino acid code
143 =cut
145 sub aa_ori {
146 my ($self,$value) = @_;
147 if( defined $value) {
148 if ( uc($value) !~ /^[ARNDCQEGHILKMFPSTWYVBZX*]$/ ) {
149 $self->throw("'$value' is not a valid one letter amino acid symbol\n");
150 } else {
151 $self->{'aa_ori'} = uc $value;
154 return $self->{'aa_ori'};
158 =head2 aa_mut
160 Title : aa_mut
161 Usage : $obj->aa_mut();
162 Function:
164 Sets and returns the mutated allele sequence. If value is not
165 set, returns false.
167 Example :
168 Returns : string
169 Args : single character amino acid code
171 =cut
174 sub aa_mut {
175 my ($self,$value) = @_;
176 if( defined $value) {
177 if ( uc($value) !~ /^[ARNDCQEGHILKMFPSTWYVBZX*]$/ ) {
178 $self->throw("'$value' is not a valid one letter amino acid symbol\n");
179 } else {
180 $self->{'aa_mut'} = uc $value;
183 return $self->{'aa_mut'};
187 =head2 codon_ori
189 Title : codon_ori
190 Usage : $obj->codon_ori();
191 Function:
193 Sets and returns codon_ori triplet. If value is not set,
194 returns false. The string has to be three characters
195 long. The character content is not checked.
197 Example :
198 Returns : string
199 Args : string
201 =cut
203 sub codon_ori {
204 my ($self,$value) = @_;
205 if( defined $value) {
206 if (length $value != 3 or lc $value =~ /[^atgc]/) {
207 $self->warn("Codon string \"$value\" is not valid unique codon");
209 $self->{'codon_ori'} = lc $value;
211 return $self->{'codon_ori'};
214 =head2 codon_table
216 Title : codon_table
217 Usage : $obj->codon_table();
218 Function:
220 Sets and returns the codon table id of the RNA
221 If value is not set, returns 1, 'universal' code, as the default.
223 Example :
224 Returns : integer
225 Args : none if get, the new value if set
227 =cut
230 sub codon_table {
231 my ($self,$value) = @_;
232 if( defined $value) {
233 if ( not $value =~ /^\d+$/ ) {
234 $self->throw("'$value' is not a valid codon table ID\n".
235 "Has to be a positive integer. Defaulting to 1\n");
236 } else {
237 $self->{'codon_table'} = $value;
240 if( ! exists $self->{'codon_table'} ) {
241 return 1;
242 } else {
243 return $self->{'codon_table'};
248 =head2 each_Variant
250 Title : each_Variant
251 Usage : $obj->each_Variant();
252 Function:
254 Returns a list of Variants.
256 Example :
257 Returns : list of Variants
258 Args : none
260 =cut
262 sub each_Variant{
263 my ($self,@args) = @_;
265 $self->throw("aa_ori is not defined\n") if not defined $self->aa_ori;
266 $self->throw("aa_mut is not defined\n") if not defined $self->aa_mut;
268 my (@points, $codon_pos, $allele_ori, $allele_mut);
269 my $ct = Bio::Tools::CodonTable->new( '-id' => $self->codon_table );
270 foreach my $codon_ori ($ct->revtranslate($self->aa_ori)) {
271 next if $self->codon_ori and $self->codon_ori ne $codon_ori;
272 foreach my $codon_mut ($ct->revtranslate($self->aa_mut)) {
273 my $k = 0;
274 my $length = 0;
275 $codon_pos = $allele_ori = $allele_mut = undef;
276 while ($k<3) {
277 my $nt_ori = substr ($codon_ori, $k, 1);
278 my $nt_mut = substr ($codon_mut, $k, 1);
279 if ($nt_ori ne $nt_mut) {
280 $length++;
281 $codon_pos = $k+1;
282 $allele_ori = $nt_ori;
283 $allele_mut = $nt_mut;
285 $k++;
287 if ($length == 1) {
288 my $rna = Bio::Variation::RNAChange->new
289 ('-length' => '1',
290 '-codon_ori' => $codon_ori,
291 '-codon_mut' => $codon_mut,
292 '-codon_pos' => $codon_pos,
293 '-isMutation' => 1
295 my $all_ori = Bio::Variation::Allele->new('-seq'=>$allele_ori);
296 $rna->allele_ori($all_ori);
297 my $all_mut = Bio::Variation::Allele->new('-seq'=>$allele_mut);
298 $rna->allele_mut($all_mut);
299 push @points, $rna;
303 return @points;