Bio/Annotation/StructuredValue.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::Annotation::StructuredValue
   4 #
   5 # Cared for by Hilmar Lapp <hlapp at gmx.net>
   6 #
   7 # (c) Hilmar Lapp, hlapp at gmx.net, 2002.
   8 # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002.
   9 #
  10 # You may distribute this module under the same terms as perl itself.
  11 # Refer to the Perl Artistic License (see the license accompanying this
  12 # software package, or see http://www.perl.com/language/misc/Artistic.html)
  13 # for the terms under which you may use, modify, and redistribute this module.
  14 #
  15 # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
  16 # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
  17 # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  18 #
  19 # POD documentation - main docs before the code
  20
  21 =head1 NAME
  22
  23 Bio::Annotation::StructuredValue - A scalar with embedded structured
  24 information
  25
  26 =head1 SYNOPSIS
  27
  28    use Bio::Annotation::StructuredValue;
  29    use Bio::Annotation::Collection;
  30
  31    my $col = Bio::Annotation::Collection->new();
  32    my $sv = Bio::Annotation::StructuredValue->new(-value => 'someval');
  33    $col->add_Annotation('tagname', $sv);
  34
  35 =head1 DESCRIPTION
  36
  37 Scalar value annotation object.
  38
  39 =head1 FEEDBACK
  40
  41 =head2 Mailing Lists
  42
  43 User feedback is an integral part of the evolution of this and other
  44 Bioperl modules. Send your comments and suggestions preferably to one
  45 of the Bioperl mailing lists. Your participation is much appreciated.
  46
  47   bioperl-l@bioperl.org                  - General discussion
  48   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  49
  50 =head2 Reporting Bugs
  51
  52 Report bugs to the Bioperl bug tracking system to help us keep track
  53 the bugs and their resolution.  Bug reports can be submitted via
  54 or the web:
  55
  56   http://bugzilla.open-bio.org/
  57
  58 =head1 AUTHOR - Hilmar Lapp
  59
  60 Email hlapp-at-gmx.net
  61
  62 =head1 APPENDIX
  63
  64 The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _
  65
  66 =cut
  67
  68
  69 # Let the code begin...
  70
  71
  72 package Bio::Annotation::StructuredValue;
  73 use strict;
  74
  75 # Object preamble - inherits from Bio::Root::Root
  76
  77 use Bio::AnnotationI;
  78 use base qw(Bio::Annotation::SimpleValue);
  79
  80 =head2 new
  81
  82  Title   : new
  83  Usage   : my $sv = Bio::Annotation::StructuredValue->new();
  84  Function: Instantiate a new StructuredValue object
  85  Returns : Bio::Annotation::StructuredValue object
  86  Args    : -value => $value to initialize the object data field [optional]
  87            -tagname => $tag to initialize the tagname [optional]
  88
  89 =cut
  90
  91 sub new{
  92    my ($class,@args) = @_;
  93
  94    my $self = $class->SUPER::new(@args);
  95
  96    my ($value,$tag) = $self->_rearrange([qw(VALUE TAGNAME)], @args);
  97    $self->{'values'} = [];
  98    defined $value  && $self->value($value);
  99    defined $tag    && $self->tagname($tag);
 100
 101    return $self;
 102 }
 103
 104
 105 =head1 AnnotationI implementing functions
 106
 107 =cut
 108
 109 =head2 as_text
 110
 111  Title   : as_text
 112  Usage   : my $text = $obj->as_text
 113  Function: return the string "Value: $v" where $v is the value
 114  Returns : string
 115  Args    : none
 116
 117
 118 =cut
 119
 120 sub as_text{
 121    my ($self) = @_;
 122
 123    return "Value: ".$self->value;
 124 }
 125
 126 =head2 display_text
 127
 128  Title   : display_text
 129  Usage   : my $str = $ann->display_text();
 130  Function: returns a string. Unlike as_text(), this method returns a string
 131            formatted as would be expected for te specific implementation.
 132
 133            One can pass a callback as an argument which allows custom text
 134            generation; the callback is passed the current instance and any text
 135            returned
 136  Example :
 137  Returns : a string
 138  Args    : [optional] callback
 139
 140 =cut
 141
 142 {
 143   my $DEFAULT_CB = sub { $_[0]->value || ''};
 144
 145   sub display_text {
 146     my ($self, $cb) = @_;
 147     $cb ||= $DEFAULT_CB;
 148     $self->throw("Callback must be a code reference") if ref $cb ne 'CODE';
 149     return $cb->($self);
 150   }
 151
 152 }
 153
 154 =head2 hash_tree
 155
 156  Title   : hash_tree
 157  Usage   : my $hashtree = $value->hash_tree
 158  Function: For supporting the AnnotationI interface just returns the value
 159            as a hashref with the key 'value' pointing to the value
 160  Returns : hashrf
 161  Args    : none
 162
 163
 164 =cut
 165
 166 sub hash_tree{
 167    my ($self) = @_;
 168
 169    my $h = {};
 170    $h->{'value'} = $self->value;
 171 }
 172
 173 =head2 tagname
 174
 175  Title   : tagname
 176  Usage   : $obj->tagname($newval)
 177  Function: Get/set the tagname for this annotation value.
 178
 179            Setting this is optional. If set, it obviates the need to provide
 180            a tag to AnnotationCollection when adding this object.
 181  Example :
 182  Returns : value of tagname (a scalar)
 183  Args    : new value (a scalar, optional)
 184
 185
 186 =cut
 187
 188 sub tagname{
 189     my ($self,$value) = @_;
 190     if( defined $value) {
 191         $self->{'tagname'} = $value;
 192     }
 193     return $self->{'tagname'};
 194 }
 195
 196
 197 =head1 Specific accessors for StructuredValue
 198
 199 =cut
 200
 201 =head2 value
 202
 203  Title   : value
 204  Usage   : $obj->value($newval)
 205  Function: Get/set the value for this annotation.
 206
 207            Set mode is here only to retain compatibility with
 208            SimpleValue. It is equivalent to calling
 209            add_value([0], $newval).
 210
 211            In get mode, this implementation allows to pass additional
 212            parameters that control how the structured annotation
 213            components will be joined together to form a
 214            string. Recognized are presently
 215                -joins     a reference to an array of join strings, the
 216                           elements at index i applying to joining
 217                           annotations at dimension i. The last element
 218                           will be re-used for dimensions higher than i.
 219                           Defaults to ['; '].
 220                -brackets  a reference to an array of two strings
 221                           denoting the opening and closing brackets for
 222                           the elements of one dimension, if there is
 223                           more than one element in the dimension.
 224                           Defaults to ['(',')'].
 225
 226  Returns : value of value
 227  Args    : newvalue (optional)
 228
 229
 230 =cut
 231
 232 sub value{
 233     my ($self,$value,@args) = @_;
 234
 235     # set mode?
 236     return $self->add_value([0], $value) if defined($value) && (@args == 0);
 237     # no, get mode
 238     # determine joins and brackets
 239     unshift(@args, $value);
 240     my ($joins, $brackets) =
 241         $self->_rearrange([qw(JOINS BRACKETS)], @args);
 242     $joins = ['; '] unless $joins;
 243     $brackets = ['(', ')'] unless $brackets;
 244     my $txt = &_to_text($self->{'values'}, $joins, $brackets);
 245     # if there's only brackets at the start and end, remove them
 246     if((@{$self->{'values'}} == 1) &&
 247        (length($brackets->[0]) == 1) && (length($brackets->[1]) == 1)) {
 248         my $re = '\\'.$brackets->[0].
 249             '([^\\'.$brackets->[1].']*)\\'.$brackets->[1];
 250         $txt =~ s/^$re$/$1/;
 251     }
 252     return $txt;
 253 }
 254
 255 sub _to_text{
 256     my ($arr, $joins, $brackets, $rec_n) = @_;
 257
 258     $rec_n = 0 unless defined($rec_n);
 259     my $i = $rec_n >= @$joins ? @$joins-1 : $rec_n;
 260     my $txt = join($joins->[$i],
 261                    map {
 262                        ref($_) ?
 263                            (ref($_) eq "ARRAY" ?
 264                                 &_to_text($_, $joins, $brackets, $rec_n+1) :
 265                                 $_->value()) :
 266                            $_;
 267                    } @$arr);
 268     if($rec_n && (@$arr > 1)) {
 269         $txt = $brackets->[0] . $txt . $brackets->[1];
 270     }
 271     return $txt;
 272 }
 273
 274 =head2 get_values
 275
 276  Title   : get_values
 277  Usage   :
 278  Function: Get the top-level array of values. Each of the elements will
 279            recursively be a reference to an array or a scalar, depending
 280            on the depth of this structured value annotation.
 281  Example :
 282  Returns : an array
 283  Args    : none
 284
 285
 286 =cut
 287
 288 sub get_values{
 289     my $self = shift;
 290
 291     return @{$self->{'values'}};
 292 }
 293
 294 =head2 get_all_values
 295
 296  Title   : get_all_values
 297  Usage   :
 298  Function: Flattens all values in this structured annotation and
 299            returns them as an array.
 300  Example :
 301  Returns : the (flat) array of values
 302  Args    : none
 303
 304
 305 =cut
 306
 307 sub get_all_values{
 308     my ($self) = @_;
 309     # we code lazy here and just take advantage of value()
 310     my $txt = $self->value(-joins => ['@!@'], -brackets => ['','']);
 311     return split(/\@!\@/, $txt);
 312 }
 313
 314 =head2 add_value
 315
 316  Title   : add_value
 317  Usage   :
 318  Function: Adds the given value to the structured annotation at the
 319            given index.
 320
 321            The index is multi-dimensional, with the first dimension
 322            applying to the first level, and so forth. If a particular
 323            dimension or a particular index does not exist yet, it will
 324            be created. If it does exist and adding the value would
 325            mean replacing a scalar with an array reference, we throw
 326            an exception to prevent unintended damage. An index of -1
 327            at any dimension means append.
 328
 329            If an array of values is to be added, it will create an
 330            additional dimension at the index specified, unless the
 331            last index value is -1, in which case they will all be
 332            appended to the last dimension.
 333
 334  Example :
 335  Returns : none
 336  Args    : the index at which to add (a reference to an array)
 337            the value(s) to add
 338
 339
 340 =cut
 341
 342 sub add_value{
 343     my ($self,$index,@values) = @_;
 344
 345     my $tree = $self->{'values'};
 346     my $lastidx = pop(@$index);
 347     foreach my $i (@$index) {
 348         if($i < 0) {
 349             my $subtree = [];
 350             push(@$tree, $subtree);
 351             $tree = $subtree;
 352         } elsif((! $tree->[$i]) || (ref($tree->[$i]) eq "ARRAY")) {
 353             $tree->[$i] = [] unless ref($tree->[$i]) eq "ARRAY";
 354             $tree = $tree->[$i];
 355         } else {
 356             $self->throw("element $i is a scalar but not in last dimension");
 357         }
 358     }
 359     if($lastidx < 0) {
 360         push(@$tree, @values);
 361     } elsif(@values < 2) {
 362         $tree->[$lastidx] = shift(@values);
 363     } else {
 364         $tree->[$lastidx] = [@values];
 365     }
 366
 367 }
 368
 369 1;