diff variant_effect_predictor/Bio/Annotation/StructuredValue.pm @ 0:1f6dce3d34e0

Uploaded

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/variant_effect_predictor/Bio/Annotation/StructuredValue.pm	Thu Apr 11 02:01:53 2013 -0400
@@ -0,0 +1,352 @@
+# $Id: StructuredValue.pm,v 1.2 2002/10/22 07:38:26 lapp Exp $
+#
+# BioPerl module for Bio::Annotation::StructuredValue
+#
+# Cared for by Hilmar Lapp <hlapp at gmx.net>
+#
+
+#
+# (c) Hilmar Lapp, hlapp at gmx.net, 2002.
+# (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002.
+#
+# You may distribute this module under the same terms as perl itself.
+# Refer to the Perl Artistic License (see the license accompanying this
+# software package, or see http://www.perl.com/language/misc/Artistic.html)
+# for the terms under which you may use, modify, and redistribute this module.
+# 
+# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+#
+
+# POD documentation - main docs before the code
+
+=head1 NAME
+
+Bio::Annotation::StructuredValue - A scalar with embedded structured
+                                   information
+
+=head1 SYNOPSIS
+
+   use Bio::Annotation::StructuredValue;
+   use Bio::Annotation::Collection;
+
+   my $col = new Bio::Annotation::Collection;
+   my $sv = new Bio::Annotation::StructuredValue(-value => 'someval');   
+   $col->add_Annotation('tagname', $sv);
+
+=head1 DESCRIPTION
+
+Scalar value annotation object 
+
+=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 one
+of 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 - bioperl
+
+Email [e-mail]
+
+Describe contact details here
+
+=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::Annotation::StructuredValue;
+use vars qw(@ISA);
+use strict;
+
+# Object preamble - inherits from Bio::Root::Root
+
+use Bio::AnnotationI;
+use Bio::Annotation::SimpleValue;
+
+@ISA = qw(Bio::Annotation::SimpleValue);
+
+=head2 new
+
+ Title   : new
+ Usage   : my $sv = new Bio::Annotation::StructuredValue;
+ Function: Instantiate a new StructuredValue object
+ Returns : Bio::Annotation::StructuredValue object
+ Args    : -value => $value to initialize the object data field [optional]
+           -tagname => $tag to initialize the tagname [optional]
+
+=cut
+
+sub new{
+   my ($class,@args) = @_;
+
+   my $self = $class->SUPER::new(@args);
+
+   my ($value,$tag) = $self->_rearrange([qw(VALUE TAGNAME)], @args);
+
+   $self->{'values'} = [];
+   defined $value  && $self->value($value);
+   defined $tag    && $self->tagname($tag);
+
+   return $self;
+}
+
+
+=head1 AnnotationI implementing functions
+
+=cut
+
+=head2 as_text
+
+ Title   : as_text
+ Usage   : my $text = $obj->as_text
+ Function: return the string "Value: $v" where $v is the value 
+ Returns : string
+ Args    : none
+
+
+=cut
+
+sub as_text{
+   my ($self) = @_;
+
+   return "Value: ".$self->value;
+}
+
+=head2 hash_tree
+
+ Title   : hash_tree
+ Usage   : my $hashtree = $value->hash_tree
+ Function: For supporting the AnnotationI interface just returns the value
+           as a hashref with the key 'value' pointing to the value
+ Returns : hashrf
+ Args    : none
+
+
+=cut
+
+sub hash_tree{
+   my ($self) = @_;
+   
+   my $h = {};
+   $h->{'value'} = $self->value;
+}
+
+=head2 tagname
+
+ Title   : tagname
+ Usage   : $obj->tagname($newval)
+ Function: Get/set the tagname for this annotation value.
+
+           Setting this is optional. If set, it obviates the need to provide
+           a tag to AnnotationCollection when adding this object.
+ Example : 
+ Returns : value of tagname (a scalar)
+ Args    : new value (a scalar, optional)
+
+
+=cut
+
+sub tagname{
+    my ($self,$value) = @_;
+    if( defined $value) {
+	$self->{'tagname'} = $value;
+    }
+    return $self->{'tagname'};
+}
+
+
+=head1 Specific accessors for StructuredValue
+
+=cut
+
+=head2 value
+
+ Title   : value
+ Usage   : $obj->value($newval)
+ Function: Get/set the value for this annotation.
+
+           Set mode is here only to retain compatibility with
+           SimpleValue. It is equivalent to calling 
+           add_value([0], $newval).
+
+           In get mode, this implementation allows to pass additional
+           parameters that control how the structured annotation
+           components will be joined together to form a
+           string. Recognized are presently
+               -joins     a reference to an array of join strings, the
+                          elements at index i applying to joining
+                          annotations at dimension i. The last element
+                          will be re-used for dimensions higher than i.
+                          Defaults to ['; '].
+               -brackets  a reference to an array of two strings
+                          denoting the opening and closing brackets for
+                          the elements of one dimension, if there is
+                          more than one element in the dimension.
+                          Defaults to ['(',')'].
+
+ Returns : value of value
+ Args    : newvalue (optional)
+
+
+=cut
+
+sub value{
+    my ($self,$value,@args) = @_;
+
+    # set mode?
+    return $self->add_value([0], $value) if defined($value) && (@args == 0);
+    # no, get mode
+    # determine joins and brackets
+    unshift(@args, $value);
+    my ($joins, $brackets) =
+	$self->_rearrange([qw(JOINS BRACKETS)], @args);
+    $joins = ['; '] unless $joins;
+    $brackets = ['(', ')'] unless $brackets;
+    my $txt = &_to_text($self->{'values'}, $joins, $brackets);
+    # if there's only brackets at the start and end, remove them
+    if((@{$self->{'values'}} == 1) &&
+       (length($brackets->[0]) == 1) && (length($brackets->[1]) == 1)) {
+	my $re = '\\'.$brackets->[0].
+	    '([^\\'.$brackets->[1].']*)\\'.$brackets->[1];
+	$txt =~ s/^$re$/$1/;
+    }
+    return $txt;
+}
+
+sub _to_text{
+    my ($arr, $joins, $brackets, $rec_n) = @_;
+
+    $rec_n = 0 unless defined($rec_n);
+    my $i = $rec_n >= @$joins ? @$joins-1 : $rec_n;
+    my $txt = join($joins->[$i],
+		   map {
+		       ref($_) ?
+			   (ref($_) eq "ARRAY" ?
+			        &_to_text($_, $joins, $brackets, $rec_n+1) :
+			        $_->value()) :
+			   $_;
+		   } @$arr);
+    if($rec_n && (@$arr > 1)) {
+	$txt = $brackets->[0] . $txt . $brackets->[1];
+    }
+    return $txt;
+}
+
+=head2 get_values
+
+ Title   : get_values
+ Usage   :
+ Function: Get the top-level array of values. Each of the elements will
+           recursively be a reference to an array or a scalar, depending
+           on the depth of this structured value annotation.
+ Example : 
+ Returns : an array
+ Args    : none
+
+
+=cut
+
+sub get_values{
+    my $self = shift;
+
+    return @{$self->{'values'}};
+}
+
+=head2 get_all_values
+
+ Title   : get_all_values
+ Usage   :
+ Function: Flattens all values in this structured annotation and
+           returns them as an array.
+ Example :
+ Returns : the (flat) array of values
+ Args    : none
+
+
+=cut
+
+sub get_all_values{
+    my ($self) = @_;
+
+    # we code lazy here and just take advantage of value()
+    my $txt = $self->value(-joins => ['@!@'], -brackets => ['','']);
+    return split(/\@!\@/, $txt);
+}
+
+=head2 add_value
+
+ Title   : add_value
+ Usage   :
+ Function: Adds the given value to the structured annotation at the
+           given index.
+
+           The index is multi-dimensional, with the first dimension
+           applying to the first level, and so forth. If a particular
+           dimension or a particular index does not exist yet, it will
+           be created. If it does exist and adding the value would
+           mean replacing a scalar with an array reference, we throw
+           an exception to prevent unintended damage. An index of -1
+           at any dimension means append.
+
+           If an array of values is to be added, it will create an
+           additional dimension at the index specified, unless the
+           last index value is -1, in which case they will all be
+           appended to the last dimension.
+
+ Example :
+ Returns : none
+ Args    : the index at which to add (a reference to an array)
+           the value(s) to add
+
+
+=cut
+
+sub add_value{
+    my ($self,$index,@values) = @_;
+
+    my $tree = $self->{'values'};
+    my $lastidx = pop(@$index);
+    foreach my $i (@$index) {
+	if($i < 0) {
+	    my $subtree = [];
+	    push(@$tree, $subtree);
+	    $tree = $subtree;
+	} elsif((! $tree->[$i]) || (ref($tree->[$i]) eq "ARRAY")) {
+	    $tree->[$i] = [] unless ref($tree->[$i]) eq "ARRAY";
+	    $tree = $tree->[$i];
+	} else {
+	    $self->throw("element $i is a scalar but not in last dimension");
+	}
+    }
+    if($lastidx < 0) {
+	push(@$tree, @values);
+    } elsif(@values < 2) {
+	$tree->[$lastidx] = shift(@values);
+    } else {
+	$tree->[$lastidx] = [@values];
+    }
+    
+}
+
+1;