Bio/Variation/AAReverseMutate.pm

   1 #
   2 # BioPerl module for Bio::Variation::AAReverseMutate
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org>
   7 #
   8 # Copyright Heikki Lehvaslaiho
   9 #
  10 # You may distribute this module under the same terms as perl itself
  11
  12 # POD documentation - main docs before the code
  13
  14 =head1 NAME
  15
  16 Bio::Variation::AAReverseMutate - point mutation and codon
  17   information from single amino acid changes
  18
  19 =head1 SYNOPSIS
  20
  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
  26                   );
  27
  28    @points = $aamut->each_Variant;
  29
  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";
  37        }
  38    } else  {
  39        print "No point mutations possible\n",
  40    }
  41
  42 =head1 DESCRIPTION
  43
  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.
  50
  51 =head1 FEEDBACK
  52
  53 =head2 Mailing Lists
  54
  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.
  58
  59   bioperl-l@bioperl.org                  - General discussion
  60   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  61
  62 =head2 Support
  63
  64 Please direct usage questions or support issues to the mailing list:
  65
  66 I<bioperl-l@bioperl.org>
  67
  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.
  72
  73 =head2 Reporting Bugs
  74
  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:
  78
  79   https://github.com/bioperl/bioperl-live/issues
  80
  81 =head1 AUTHOR - Heikki Lehvaslaiho
  82
  83 Email:  heikki-at-bioperl-dot-org
  84
  85 =head1 APPENDIX
  86
  87 The rest of the documentation details each of the object
  88 methods. Internal methods are usually preceded with a _
  89
  90 =cut
  91
  92
  93 # Let the code begin...
  94
  95 package Bio::Variation::AAReverseMutate;
  96
  97 use strict;
  98
  99 # Object preamble - inheritance
 100 use Bio::Tools::CodonTable;
 101 use Bio::Variation::RNAChange;
 102 use Bio::Variation::Allele;
 103
 104 use base qw(Bio::Root::Root);
 105
 106 sub new {
 107     my($class,@args) = @_;
 108     my $self = $class->SUPER::new(@args);
 109
 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);
 116
 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);
 121
 122   return $self; # success - we hope!
 123
 124 }
 125
 126
 127 =head2 aa_ori
 128
 129  Title   : aa_ori
 130  Usage   : $obj->aa_ori();
 131  Function:
 132
 133             Sets and returns original aa sequence.  If value is not
 134             set, returns false.
 135
 136             Amino acid sequences are stored in upper case characters,
 137             others in lower case.
 138
 139  Example :
 140  Returns : string
 141  Args    : single character amino acid code
 142
 143 =cut
 144
 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;
 152         }
 153     }
 154     return $self->{'aa_ori'};
 155 }
 156
 157
 158 =head2 aa_mut
 159
 160  Title   : aa_mut
 161  Usage   : $obj->aa_mut();
 162  Function:
 163
 164             Sets and returns the mutated allele sequence.  If value is not
 165             set, returns false.
 166
 167  Example :
 168  Returns : string
 169  Args    : single character amino acid code
 170
 171 =cut
 172
 173
 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;
 181         }
 182     }
 183     return $self->{'aa_mut'};
 184 }
 185
 186
 187 =head2 codon_ori
 188
 189  Title   : codon_ori
 190  Usage   : $obj->codon_ori();
 191  Function:
 192
 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 chracter content is not checked.
 196
 197  Example :
 198  Returns : string
 199  Args    : string
 200
 201 =cut
 202
 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");
 208         }
 209         $self->{'codon_ori'} = lc $value;
 210     }
 211     return $self->{'codon_ori'};
 212 }
 213
 214 =head2 codon_table
 215
 216  Title   : codon_table
 217  Usage   : $obj->codon_table();
 218  Function:
 219
 220             Sets and returns the codon table id of the RNA
 221             If value is not set, returns 1, 'universal' code, as the default.
 222
 223  Example :
 224  Returns : integer
 225  Args    : none if get, the new value if set
 226
 227 =cut
 228
 229
 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;
 238         }
 239     }
 240     if( ! exists $self->{'codon_table'} ) {
 241         return 1;
 242     } else {
 243         return $self->{'codon_table'};
 244     }
 245 }
 246
 247
 248 =head2 each_Variant
 249
 250  Title   : each_Variant
 251  Usage   : $obj->each_Variant();
 252  Function:
 253
 254             Returns a list of Variants.
 255
 256  Example :
 257  Returns : list of Variants
 258  Args    : none
 259
 260 =cut
 261
 262 sub each_Variant{
 263    my ($self,@args) = @_;
 264
 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;
 267
 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;
 284                }
 285                $k++;
 286            }
 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
 294                     );
 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;
 300            }
 301        }
 302    }
 303    return @points;
 304 }
 305
 306 1;