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

Uploaded

# $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;