lib/Bio/Annotation/StructuredValue.pm

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