Bio/Annotation/StructuredValue.pm

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