diff variant_effect_predictor/Bio/Variation/DNAMutation.pm @ 0:2bc9b66ada89 draft default tip

Uploaded

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/variant_effect_predictor/Bio/Variation/DNAMutation.pm	Thu Apr 11 06:29:17 2013 -0400
@@ -0,0 +1,391 @@
+# $Id: DNAMutation.pm,v 1.11 2002/10/22 07:38:49 lapp Exp $
+#
+# BioPerl module for Bio::Variation::DNAMutation
+#
+# Cared for by Heikki Lehvaslaiho <[e-mail]>
+#
+# Copyright Heikki Lehvaslaiho
+#
+# You may distribute this module under the same terms as perl itself
+
+# POD documentation - main docs before the code
+
+=head1 NAME
+
+Bio::Variation::DNAMutation - DNA level mutation class
+
+=head1 SYNOPSIS
+
+    $dnamut = Bio::Variation::DNAMutation->new
+        ('-start'         => $start,
+         '-end'           => $end,
+         '-length'        => $len,
+         '-upStreamSeq'   => $upflank,
+         '-dnStreamSeq'   => $dnflank,
+         '-proof'         => $proof,
+	 '-isMutation'    => 1,
+         '-mut_number'    => $mut_number
+        );
+    $a1 = Bio::Variation::Allele->new;
+    $a1->seq('a');
+    $dnamut->allele_ori($a1);
+    my $a2 = Bio::Variation::Allele->new;
+    $a2->seq('t');
+    $dnamut->add_Allele($a2);
+
+    print "Restriction changes are ", $dnamut->restriction_changes, "\n";
+
+    # add it to a SeqDiff container object
+    $seqdiff->add_Variant($dnamut);
+
+
+=head1 DESCRIPTION
+
+The instantiable class Bio::Variation::DNAMutation describes basic
+sequence changes in genomic DNA level. It uses methods defined in
+superclass Bio::Variation::VariantI. See L<Bio::Variation::VariantI>
+for details.
+
+If the variation described by a DNAMutation object is transcibed, link
+the corresponding Bio::Variation::RNAChange object to it using
+method RNAChange(). See L<Bio::Variation::RNAChange> for more information.
+
+=head1 FEEDBACK
+
+=head2 Mailing Lists
+
+User feedback is an integral part of the evolution of this and other
+Bioperl modules. Send your comments and suggestions preferably to the 
+Bioperl mailing lists  Your participation is much appreciated.
+
+  [e-mail]                         - General discussion
+  http://bio.perl.org/MailList.html             - About the mailing lists
+
+=head2 Reporting Bugs
+
+report bugs to the Bioperl bug tracking system to help us keep track
+ the bugs and their resolution.  Bug reports can be submitted via
+ email or the web:
+
+  [e-mail]
+  http://bugzilla.bioperl.org/
+
+=head1 AUTHOR - Heikki Lehvaslaiho
+
+Email:  [e-mail]
+Address: 
+
+     EMBL Outstation, European Bioinformatics Institute
+     Wellcome Trust Genome Campus, Hinxton
+     Cambs. CB10 1SD, United Kingdom 
+
+=head1 APPENDIX
+
+The rest of the documentation details each of the object
+methods. Internal methods are usually preceded with a _
+
+=cut
+
+
+# Let the code begin...
+
+
+package Bio::Variation::DNAMutation;
+my $VERSION=1.0;
+use vars qw(@ISA);
+use strict;
+
+# Object preamble - inheritance
+use Bio::Variation::VariantI;
+
+@ISA = qw( Bio::Variation::VariantI );
+
+sub new {
+    my($class,@args) = @_;
+    my $self = $class->SUPER::new(@args);
+    
+    my ($start, $end, $length, $strand, $primary, $source, 
+	$frame, $score, $gff_string,
+	$allele_ori,  $allele_mut,  $upstreamseq,  $dnstreamseq,  
+	$label,  $status,  $proof,  $region, $region_value, $region_dist, $numbering, 
+	$cpg, $mut_number, $ismutation) =
+	    $self->_rearrange([qw(START
+				  END
+				  LENGTH
+				  STRAND
+				  PRIMARY
+				  SOURCE
+				  FRAME
+				  SCORE
+				  GFF_STRING
+				  ALLELE_ORI
+				  ALLELE_MUT
+				  UPSTREAMSEQ
+				  DNSTREAMSEQ
+				  LABEL
+				  STATUS
+				  PROOF
+				  REGION
+				  REGION_VALUE
+				  REGION_DIST
+				  NUMBERING
+				  CPG
+				  MUT_NUMBER
+				  ISMUTATION
+				  )],
+			      @args);
+
+    $self->primary_tag("Variation");
+
+    $self->{ 'alleles' } = [];
+
+    $start && $self->start($start);
+    $end   && $self->end($end);
+    $length && $self->length($length);
+    $strand && $self->strand($strand);
+    $primary && $self->primary_tag($primary);
+    $source  && $self->source_tag($source);
+    $frame   && $self->frame($frame);
+    $score   && $self->score($score);
+    $gff_string && $self->_from_gff_string($gff_string);
+    
+    $allele_ori && $self->allele_ori($allele_ori);
+    $allele_mut  && $self->allele_mut($allele_mut);
+    $upstreamseq  && $self->upStreamSeq($upstreamseq);
+    $dnstreamseq  && $self->dnStreamSeq($dnstreamseq);
+    
+    $label  && $self->label($label);
+    $status  && $self->status($status);
+    $proof && $self->proof($proof);
+    $region  && $self->region($region);
+    $region_value  && $self->region_value($region_value);
+    $region_dist  && $self->region_dist($region_dist);
+    $numbering && $self->numbering($numbering);
+    $mut_number && $self->mut_number($mut_number);
+    $ismutation && $self->isMutation($ismutation);
+
+    $cpg && $self->CpG($cpg);
+    
+    return $self; # success - we hope!
+}
+
+
+=head2 CpG
+
+ Title   : CpG
+ Usage   : $obj->CpG()
+ Function: sets and returns boolean values for variation 
+           hitting a CpG site.  Unset value return -1.
+ Example : $obj->CpG()
+ Returns : boolean
+ Args    : optional true of false value
+
+
+=cut
+
+
+sub CpG {
+   my ($obj,$value) = @_;
+   if( defined $value) {
+       $value ? ($value = 1) : ($value = 0);
+       $obj->{'cpg'} = $value;
+   }
+    elsif (not defined $obj->{'label'}) {
+	$obj->{'cpg'} = $obj->_CpG_value;
+    }
+   else {
+       return $obj->{'cpg'};
+   }
+}
+
+
+
+sub _CpG_value {
+    my ($self) = @_;
+    if ($self->allele_ori eq $self->allele_mut and length ($self->allele_ori) == 1 ) {
+    
+	# valid only for point mutations
+	# CpG methylation-mediated deamination:
+	#   CG -> TG | CG -> CA substitutions
+	# implementation here is  less strict: if CpG dinucleotide was hit
+	
+	if ( ( ($self->allele_ori eq 'c') && (substr($self->upStreamSeq, 0, 1) eq 'g') ) ||
+	     ( ($self->allele_ori eq 'g') && (substr($self->dnStreamSeq, -1, 1) eq 'c') ) ) {
+	    return 1;
+	}
+	else {
+	    return 0;
+	}
+    } else {
+	$self->warn('CpG makes sense only in the context of point mutation');
+	return undef;
+    }
+}
+
+
+=head2 RNAChange
+
+ Title   : RNAChange
+ Usage   : $mutobj = $obj->RNAChange;
+         : $mutobj = $obj->RNAChange($objref);
+ Function: Returns or sets the link-reference to a mutation/change object.
+           If there is no link, it will return undef
+ Returns : an obj_ref or undef
+
+=cut
+
+
+sub RNAChange {
+  my ($self,$value) = @_;
+  if (defined $value) {
+      if( ! $value->isa('Bio::Variation::RNAChange') ) {
+	  $self->throw("Is not a Bio::Variation::RNAChange object but a [$self]");
+	  return (undef);
+      }
+      else {
+	  $self->{'RNAChange'} = $value;
+      }
+  }
+  unless (exists $self->{'RNAChange'}) {
+      return (undef);
+  } else {
+      return $self->{'RNAChange'};
+  }
+}
+
+
+=head2 label
+
+ Title   : label
+ Usage   : $obj->label();
+ Function: 
+
+            Sets and returns mutation event label(s).  If value is not
+            set, or no argument is given returns false.  Each
+            instantiable subclass of L<Bio::Variation::VariantI> needs
+            to implement this method. Valid values are listed in
+            'Mutation event controlled vocabulary' in
+            http://www.ebi.ac.uk/mutations/recommendations/mutevent.html.
+
+ Example : 
+ Returns : string
+ Args    : string
+
+=cut
+
+
+sub label {
+    my ($self, $value) = @_;
+    my ($o, $m, $type);
+    $o = $self->allele_ori->seq if $self->allele_ori and $self->allele_ori->seq;
+    $m = $self->allele_mut->seq if $self->allele_mut and $self->allele_mut->seq;
+    
+    if (not $o and not $m ) {
+	$self->warn("[DNAMutation, label] Both alleles should not be empty!\n");
+	$type = 'no change'; # is this enough?
+    }
+    elsif ($o && $m && length($o) == length($m) && length($o) == 1) {
+	$type = 'point';
+	$type .= ", ". _point_type_label($o, $m);
+    }
+    elsif (not $o ) {
+	$type = 'insertion';
+    }
+    elsif (not $m  ) {
+	$type = 'deletion';
+    }
+    else {
+	$type = 'complex';
+    }
+    $self->{'label'} = $type;
+    return $self->{'label'};
+}
+
+
+sub _point_type_label {
+    my ($o, $m) = @_;
+    my ($type);
+    my %transition = ('a' => 'g',
+		   'g' => 'a',
+		   'c' => 't',
+		   't' => 'c');
+    $o = lc $o;
+    $m = lc $m;
+    if ($o eq $m) {
+	$type = 'no change';
+    }
+    elsif ($transition{$o} eq $m ) {
+	$type = 'transition';
+    }
+    else {
+	$type = 'transversion';
+    }
+}
+
+
+=head2 sysname
+
+ Title   : sysname
+ Usage   : $self->sysname
+ Function: 
+
+           This subroutine creates a string corresponding to the
+           'systematic name' of the mutation. Systematic name is
+           specified in Antonorakis & MDI Nomenclature Working Group:
+           Human Mutation 11:1-3, 1998. 
+           http://www.interscience.wiley.com/jpages/1059-7794/nomenclature.html
+ Returns : string
+
+=cut
+
+
+sub sysname {
+    my ($self,$value) = @_;
+    if( defined $value) {
+	$self->{'sysname'} = $value;
+    } else {
+	$self->warn('Mutation start position is not defined') 
+	    if not defined $self->start;
+	my $sysname = '';
+	# show the alphabet only if $self->SeqDiff->alphabet is set;
+	my $mol = '';
+	if ($self->SeqDiff->alphabet && $self->SeqDiff->alphabet eq 'dna') {
+	    $mol = 'g.';
+	}
+	elsif ($self->SeqDiff->alphabet && $self->SeqDiff->alphabet eq 'rna') {
+	    $mol = 'c.';
+	}
+	my $sep;
+	if ($self->isMutation) {
+	    $sep = '>';
+	} else {
+	    $sep = '|';
+	}
+	my $sign = '+'; 
+	$sign = '' if $self->start < 1;
+	$sysname .=  $mol ;#if $mol;
+	$sysname .= $sign. $self->start;
+
+	my @alleles = $self->each_Allele;
+	$self->allele_mut($alleles[0]);
+
+	$sysname .= 'del' if $self->label =~ /deletion/;
+	$sysname .= 'ins' if $self->label =~ /insertion/;
+	$sysname .=  uc $self->allele_ori->seq if $self->allele_ori->seq;
+
+
+
+	#push @alleles, $self->allele_mut if $self->allele_mut;
+	foreach my $allele (@alleles) {
+	    $self->allele_mut($allele);
+	    $sysname .= $sep if $self->label =~ /point/ or $self->label =~ /complex/;
+	    $sysname .=  uc $self->allele_mut->seq if $self->allele_mut->seq;
+	}
+	$self->{'sysname'} = $sysname;
+	#$self->{'sysname'} = $sign. $self->start. 
+	#    uc $self->allele_ori->seq. $sep. uc $self->allele_mut->seq;
+    }
+    return $self->{'sysname'};
+}
+
+1;