Bio/SeqFeature/Annotated.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::SeqFeature::Annotated
   4 #
   5 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   6 #
   7 # Cared for by Allen Day <allenday at ucla.edu>
   8 #
   9 # Copyright Allen Day
  10 #
  11 # You may distribute this module under the same terms as perl itself
  12
  13 # POD documentation - main docs before the code
  14
  15 =head1 NAME
  16
  17 Bio::SeqFeature::Annotated - PLEASE PUT SOMETHING HERE
  18
  19 =head1 SYNOPSIS
  20
  21     # none yet, complain to authors
  22
  23 =head1 DESCRIPTION
  24
  25 None yet, complain to authors.
  26
  27 =head1 Implemented Interfaces
  28
  29 This class implements the following interfaces.
  30
  31 =over 4
  32
  33 =item Bio::SeqFeatureI
  34
  35 Note that this includes implementing Bio::RangeI.
  36
  37 =item Bio::AnnotatableI
  38
  39 =item Bio::FeatureHolderI
  40
  41 Features held by a feature are essentially sub-features.
  42
  43 =back
  44
  45 =head1 FEEDBACK
  46
  47 =head2 Mailing Lists
  48
  49 User feedback is an integral part of the evolution of this and other
  50 Bioperl modules. Send your comments and suggestions preferably to one
  51 of the Bioperl mailing lists.  Your participation is much appreciated.
  52
  53   bioperl-l@bioperl.org                  - General discussion
  54   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  55
  56 =head2 Support
  57
  58 Please direct usage questions or support issues to the mailing list:
  59
  60 L<bioperl-l@bioperl.org>
  61
  62 rather than to the module maintainer directly. Many experienced and
  63 reponsive experts will be able look at the problem and quickly
  64 address it. Please include a thorough description of the problem
  65 with code and data examples if at all possible.
  66
  67 =head2 Reporting Bugs
  68
  69 Report bugs to the Bioperl bug tracking system to help us keep track
  70 the bugs and their resolution.  Bug reports can be submitted via
  71 the web:
  72
  73   http://bugzilla.open-bio.org/
  74
  75 =head1 AUTHOR - Allen Day
  76
  77 Allen Day E<lt>allenday at ucla.eduE<gt>
  78
  79 =head1 APPENDIX
  80
  81 The rest of the documentation details each of the object
  82 methods. Internal methods are usually preceded with a _
  83
  84 =cut
  85
  86
  87 package Bio::SeqFeature::Annotated;
  88
  89 use strict;
  90
  91 use Bio::Annotation::Collection;
  92 use Bio::Annotation::OntologyTerm;
  93 use Bio::Annotation::Target;
  94 use Bio::LocatableSeq;
  95 use Bio::Location::Simple;
  96 use Bio::Ontology::OntologyStore;
  97 use Bio::Tools::GFF;
  98 use Bio::SeqFeature::AnnotationAdaptor;
  99 use Data::Dumper;
 100 use URI::Escape;
 101
 102 use base qw(Bio::Root::Root
 103     Bio::SeqFeature::TypedSeqFeatureI
 104     Bio::AnnotatableI
 105     Bio::FeatureHolderI);
 106
 107 our %tagclass = (
 108   comment        => 'Bio::Annotation::Comment',
 109   dblink         => 'Bio::Annotation::DBLink',
 110   description    => 'Bio::Annotation::SimpleValue',
 111   gene_name      => 'Bio::Annotation::SimpleValue',
 112   ontology_term  => 'Bio::Annotation::OntologyTerm',
 113   reference      => 'Bio::Annotation::Reference',
 114   __DEFAULT__    => 'Bio::Annotation::SimpleValue',
 115 );
 116
 117 our %tag2text = (
 118   'Bio::Annotation::Comment'        => 'text',
 119   'Bio::Annotation::DBLink'         => 'primary_id',
 120   'Bio::Annotation::SimpleValue'    => 'value',
 121   'Bio::Annotation::SimpleValue'    => 'value',
 122   'Bio::Annotation::OntologyTerm'   => 'name',
 123   'Bio::Annotation::Reference'      => 'title',
 124   __DEFAULT__                       => 'value',
 125 );
 126
 127 ######################################
 128 #get_SeqFeatures
 129 #display_name
 130 #primary_tag
 131 #source_tag                       x with warning
 132 #has_tag
 133 #get_tag_values
 134 #get_tagset_values
 135 #get_all_tags
 136 #attach_seq
 137 #seq                              x
 138 #entire_seq                       x
 139 #seq_id
 140 #gff_string
 141 #_static_gff_handler
 142 #start                            x
 143 #end                              x
 144 #strand                           x
 145 #location
 146 #primary_id
 147
 148 =head1 PREAMBLE
 149
 150 Okay, where to start...
 151
 152 The original idea for this class appears to lump all SeqFeatureI data
 153 (primary_tag, source_tag, etc) into AnnotationI objects into an
 154 Bio::Annotation::Collection. The type is then checked against SOFA.
 155
 156 There have been several requests to have type checking be optionally run.
 157
 158 Bio::FeatureHolderI::create_hierarchy_from_ParentIDs
 159 Bio::FeatureHolderI::feature_count
 160 Bio::FeatureHolderI::get_all_SeqFeatures
 161 Bio::FeatureHolderI::set_ParentIDs_from_hierarchy
 162 Bio::RangeI::contains
 163 Bio::RangeI::disconnected_ranges
 164 Bio::RangeI::equals
 165 Bio::RangeI::intersection
 166 Bio::RangeI::offsetStranded
 167 Bio::RangeI::overlap_extent
 168 Bio::RangeI::overlaps
 169 Bio::RangeI::subtract
 170 Bio::RangeI::union
 171 Bio::SeqFeature::Annotated::Dumper
 172 Bio::SeqFeature::Annotated::MAX_TYPE_CACHE_MEMBERS
 173 Bio::SeqFeature::Annotated::add_Annotation
 174 Bio::SeqFeature::Annotated::add_SeqFeature
 175 Bio::SeqFeature::Annotated::add_tag_value
 176 Bio::SeqFeature::Annotated::add_target
 177 Bio::SeqFeature::Annotated::annotation
 178 Bio::SeqFeature::Annotated::attach_seq
 179 Bio::SeqFeature::Annotated::display_name
 180 Bio::SeqFeature::Annotated::each_target
 181 Bio::SeqFeature::Annotated::end
 182 Bio::SeqFeature::Annotated::entire_seq
 183 Bio::SeqFeature::Annotated::frame
 184 Bio::SeqFeature::Annotated::from_feature
 185 Bio::SeqFeature::Annotated::get_Annotations
 186 Bio::SeqFeature::Annotated::get_SeqFeatures
 187 Bio::SeqFeature::Annotated::get_all_tags
 188 Bio::SeqFeature::Annotated::get_tag_values
 189 Bio::SeqFeature::Annotated::get_tagset_values
 190 Bio::SeqFeature::Annotated::has_tag
 191 Bio::SeqFeature::Annotated::length
 192 Bio::SeqFeature::Annotated::location
 193 Bio::SeqFeature::Annotated::name
 194 Bio::SeqFeature::Annotated::new
 195 Bio::SeqFeature::Annotated::phase
 196 Bio::SeqFeature::Annotated::primary_tag
 197 Bio::SeqFeature::Annotated::remove_Annotations
 198 Bio::SeqFeature::Annotated::remove_SeqFeatures
 199 Bio::SeqFeature::Annotated::remove_tag
 200 Bio::SeqFeature::Annotated::score
 201 Bio::SeqFeature::Annotated::seq
 202 Bio::SeqFeature::Annotated::seq_id
 203 Bio::SeqFeature::Annotated::source
 204 Bio::SeqFeature::Annotated::source_tag
 205 Bio::SeqFeature::Annotated::start
 206 Bio::SeqFeature::Annotated::strand
 207 Bio::SeqFeature::Annotated::type
 208 Bio::SeqFeature::Annotated::uri_escape
 209 Bio::SeqFeature::Annotated::uri_unescape
 210 Bio::SeqFeature::TypedSeqFeatureI::croak
 211 Bio::SeqFeature::TypedSeqFeatureI::ontology_term
 212 Bio::SeqFeatureI::generate_unique_persistent_id
 213 Bio::SeqFeatureI::gff_string
 214 Bio::SeqFeatureI::primary_id
 215 Bio::SeqFeatureI::spliced_seq
 216
 217 =cut
 218
 219 sub new {
 220     my ( $caller, @args) = @_;
 221     my ($self) = $caller->SUPER::new(@args);
 222
 223     $self->_initialize(@args);
 224
 225     return $self;
 226 }
 227
 228 sub _initialize {
 229   my ($self,@args) = @_;
 230   my ($start, $end, $strand, $frame, $phase, $score,
 231       $name, $annot, $location,
 232       $display_name, # deprecate
 233       $seq_id, $type,$source,$feature
 234      ) =
 235         $self->_rearrange([qw(START
 236                               END
 237                               STRAND
 238                               FRAME
 239                               PHASE
 240                               SCORE
 241                               NAME
 242                               ANNOTATION
 243                               LOCATION
 244                               DISPLAY_NAME
 245                               SEQ_ID
 246                               TYPE
 247                               SOURCE
 248                               FEATURE
 249                              )], @args);
 250   defined $start        && $self->start($start);
 251   defined $end          && $self->end($end);
 252   defined $strand       && $self->strand($strand);
 253   defined $frame        && $self->frame($frame);
 254   defined $phase        && $self->phase($phase);
 255   defined $score        && $self->score($score);
 256   defined $source       && ref($source) ? $self->source($source) : $self->source_tag($source);
 257   defined $type         && ref($type) ? $self->type($type) : $self->primary_tag($type);
 258   defined $location     && $self->location($location);
 259   defined $annot        && $self->annotation($annot);
 260   defined $feature      && $self->from_feature($feature);
 261
 262   if( defined($display_name) && defined($name) ){
 263           $self->throw('Cannot define (-id and -seq_id) or (-name and -display_name) attributes');
 264   }
 265   defined $seq_id                   && $self->seq_id($seq_id);
 266   defined ($name || $display_name)  && $self->name($name || $display_name);
 267 }
 268
 269 =head1 ATTRIBUTE ACCESSORS FOR Bio::SeqFeature::Annotated
 270
 271 =cut
 272
 273 =head2 from_feature
 274
 275   Usage: $obj->from_feature($myfeature);
 276   Desc : initialize this object with the contents of another feature
 277          object.  Useful for converting objects like
 278          L<Bio::SeqFeature::Generic> to this class
 279   Ret  : nothing meaningful
 280   Args : a single object of some other feature type,
 281   Side Effects: throws error on failure
 282   Example:
 283
 284 =cut
 285
 286 sub from_feature {
 287     my ($self,$feat,%opts) = @_;
 288
 289     # should deal with any SeqFeatureI implementation (i.e. we don't want to
 290     # automatically force a OO-heavy implementation on all classes)
 291     ref($feat) && ($feat->isa('Bio::SeqFeatureI'))
 292       or $self->throw('invalid arguments to from_feature');
 293
 294     #TODO: add overrides in opts for these values, so people don't have to screw up their feature object
 295     #if they don't want to
 296
 297     ### set most of the data
 298     foreach my $fieldname (qw/ start end strand frame score location seq_id source_tag primary_tag/) {
 299       #no strict 'refs'; #using symbolic refs, yes, but using them for methods is allowed now
 300       $self->$fieldname( $feat->$fieldname );
 301     }
 302
 303     # now pick up the annotations/tags of the other feature
 304     # We'll use AnnotationAdaptor to convert everything over
 305
 306     my %no_copy = map {$_ => 1} qw/seq_id source type frame phase score/;
 307     my $adaptor = Bio::SeqFeature::AnnotationAdaptor->new(-feature => $feat);
 308     for my $key ( $adaptor->get_all_annotation_keys() ) {
 309         next if $no_copy{$key};
 310         my @values = $adaptor->get_Annotations($key);
 311         @values = _aggregate_scalar_annotations(\%opts,$key,@values);
 312         foreach my $val (@values) {
 313             $self->add_Annotation($key,$val)
 314         }
 315     }
 316 }
 317 #given a key and its values, make the values into
 318 #Bio::Annotation::\w+ objects
 319
 320 sub _aggregate_scalar_annotations {
 321   my ($opts,$key,@values) = @_;
 322
 323   #anything that's not an object, make it a SimpleValue
 324   @values = map { ref($_) ? $_ : Bio::Annotation::SimpleValue->new(-value => $_) } @values;
 325
 326   #try to make Target objects
 327   if($key eq 'Target' && (@values == 3 || @values == 4)
 328      && @values == grep {$_->isa('Bio::Annotation::SimpleValue')} @values
 329     ) {
 330     @values = map {$_->value} @values;
 331     #make a strand if it doesn't have one, enforcing start <= end
 332     if(@values == 3) {
 333       if($values[1] <= $values[2]) {
 334         $values[3] = '+';
 335       } else {
 336         @values[1,2] = @values[2,1];
 337         $values[3] = '-';
 338       }
 339     }
 340     return ( Bio::Annotation::Target->new( -target_id => $values[0],
 341                                            -start     => $values[1],
 342                                            -end       => $values[2],
 343                                            -strand    => $values[3],
 344                                          )
 345            );
 346   }
 347   #try to make DBLink objects
 348   elsif($key eq 'dblink' || $key eq 'Dbxref') {
 349     return map {
 350       if( /:/ ) { #convert to a DBLink if it has a colon in it
 351         my ($db,$id) = split /:/,$_->value;
 352         Bio::Annotation::DBLink->new( -database   => $db,
 353                                       -primary_id => $id,
 354                                     );
 355       } else { #otherwise leave as a SimpleValue
 356         $_
 357       }
 358     } @values;
 359   }
 360   #make OntologyTerm objects
 361   elsif($key eq 'Ontology_term') {
 362     return map { Bio::Annotation::OntologyTerm->new(-identifier => $_->value) } @values
 363   }
 364   #make Comment objects
 365   elsif($key eq 'comment') {
 366     return map { Bio::Annotation::Comment->new( -text => $_->value ) } @values;
 367   }
 368
 369   return @values;
 370 }
 371
 372
 373 =head2 seq_id()
 374
 375  Usage   : $obj->seq_id($newval)
 376  Function: holds a string corresponding to the unique
 377            seq_id of the sequence underlying the feature
 378            (e.g. database accession or primary key).
 379  Returns : string representing the seq_id.
 380  Args    : on set, some string or a Bio::Annotation::SimpleValue object.
 381
 382 =cut
 383
 384 sub seq_id {
 385   my($self,$val) = @_;
 386   if (defined($val)) {
 387       my $term = undef;
 388       if (!ref($val)) {
 389           $term = Bio::Annotation::SimpleValue->new(-value => uri_unescape($val));
 390       } elsif (ref($val) && $val->isa('Bio::Annotation::SimpleValue')) {
 391           $term = $val;
 392       }
 393       if (!defined($term) || ($term->value =~ /^>/)) {
 394           $self->throw('give seq_id() a scalar or Bio::Annotation::SimpleValue object, not '.$val);
 395       }
 396       $self->remove_Annotations('seq_id');
 397       $self->add_Annotation('seq_id', $term);
 398   }
 399
 400   $self->seq_id('.') unless $self->get_Annotations('seq_id'); # make sure we always have something
 401
 402   return ($self->get_Annotations('seq_id'))[0]->value;
 403 }
 404
 405 =head2 name()
 406
 407  Usage   : $obj->name($newval)
 408  Function: human-readable name for the feature.
 409  Returns : value of name (a scalar)
 410  Args    : on set, new value (a scalar or undef, optional)
 411
 412 =cut
 413
 414 sub name {
 415   my($self,$val) = @_;
 416   $self->{'name'} = $val if defined($val);
 417   return $self->{'name'};
 418 }
 419
 420 =head2 type()
 421
 422  Usage   : $obj->type($newval)
 423  Function: a SOFA type for the feature.
 424  Returns : Bio::Annotation::OntologyTerm object representing the type.
 425            NB: to get a string, use primary_tag().
 426  Args    : on set, Bio::Annotation::OntologyTerm object.
 427            NB: to set a string (SOFA name or identifier), use primary_tag()
 428
 429 =cut
 430
 431 use constant MAX_TYPE_CACHE_MEMBERS => 20;
 432 sub type {
 433   my($self,$val) = @_;
 434   if(defined($val)){
 435     my $term = undef;
 436
 437     if(!ref($val)){
 438       $self->throw("give type() a Bio::Annotation::OntologyTerm object, not a string");
 439     }
 440     elsif(ref($val) && $val->isa('Bio::Annotation::OntologyTerm')){
 441       $term = $val;
 442     }
 443     else {
 444       #we have the wrong type of object
 445       $self->throw('give type() a SOFA term name, identifier, or Bio::Annotation::OntologyTerm object, not '.$val);
 446     }
 447     $self->remove_Annotations('type');
 448     $self->add_Annotation('type',$term);
 449   }
 450
 451   return $self->get_Annotations('type');
 452 }
 453
 454 =head2 source()
 455
 456  Usage   : $obj->source($newval)
 457  Function: holds the source of the feature.
 458  Returns : a Bio::Annotation::SimpleValue representing the source.
 459            NB: to get a string, use source_tag()
 460  Args    : on set, a Bio::Annotation::SimpleValue object.
 461            NB: to set a string, use source_tag()
 462
 463 =cut
 464
 465 sub source {
 466   my($self,$val) = @_;
 467
 468   if (defined($val)) {
 469       my $term;
 470       if (!ref($val)) {
 471         $self->throw("give source() a Bio::Annotation::SimpleValue object, not a string");
 472         #$term = Bio::Annotation::SimpleValue->new(-value => uri_unescape($val));
 473       } elsif (ref($val) && $val->isa('Bio::Annotation::SimpleValue')) {
 474           $term = $val;
 475       } else {
 476           $self->throw('give source() a scalar or Bio::Annotation::SimpleValue object, not '.$val);
 477       }
 478       $self->remove_Annotations('source');
 479       $self->add_Annotation('source', $term);
 480   }
 481
 482   unless ($self->get_Annotations('source')) {
 483     $self->source(Bio::Annotation::SimpleValue->new(-value => '.'));
 484   }
 485   return $self->get_Annotations('source');
 486 }
 487
 488 =head2 score()
 489
 490  Usage   : $score = $feat->score()
 491            $feat->score($score)
 492  Function: holds a value corresponding to the score of the feature.
 493  Returns : a string representing the score.
 494  Args    : on set, a scalar or a Bio::Annotation::SimpleValue object.
 495
 496 =cut
 497
 498 sub score {
 499   my $self = shift;
 500   my $val = shift;
 501
 502   if(defined($val)){
 503       my $term = undef;
 504       if (!ref($val)) {
 505           $term = Bio::Annotation::SimpleValue->new(-value => $val);
 506       } elsif (ref($val) && $val->isa('Bio::Annotation::SimpleValue')) {
 507           $term = $val;
 508       }
 509
 510       if ($term->value ne '.' &&
 511            (!defined($term) || ($term->value !~ /^[+-]?\d+\.?\d*(e-\d+)?/))) {
 512           $self->throw("'$val' is not a valid score");
 513       }
 514       $self->remove_Annotations('score');
 515       $self->add_Annotation('score', $term);
 516   }
 517
 518   $self->score('.') unless scalar($self->get_Annotations('score')); # make sure we always have something
 519
 520   return ($self->get_Annotations('score'))[0]->display_text;
 521 }
 522
 523 =head2 phase()
 524
 525  Usage   : $phase = $feat->phase()
 526            $feat->phase($phase)
 527  Function: get/set on phase information
 528  Returns : a string 0,1,2,'.'
 529  Args    : on set, one of 0,1,2,'.' or a Bio::Annotation::SimpleValue
 530            object holding one of 0,1,2,'.' as its value.
 531
 532 =cut
 533
 534 sub phase {
 535   my $self = shift;
 536   my $val = shift;
 537
 538   if(defined($val)){
 539       my $term = undef;
 540       if (!ref($val)) {
 541           $term = Bio::Annotation::SimpleValue->new(-value => $val);
 542       } elsif (ref($val) && $val->isa('Bio::Annotation::SimpleValue')) {
 543           $term = $val;
 544       }
 545       if (!defined($term) || ($term->value !~ /^[0-2.]$/)) {
 546           $self->throw("'$val' is not a valid phase");
 547       }
 548       $self->remove_Annotations('phase');
 549       $self->add_Annotation('phase', $term);
 550   }
 551
 552   $self->phase('.') unless $self->get_Annotations('phase'); # make sure we always have something
 553
 554   return ($self->get_Annotations('phase'))[0]->value;
 555 }
 556
 557
 558 =head2 frame()
 559
 560  Usage   : $frame = $feat->frame()
 561            $feat->frame($phase)
 562  Function: get/set on phase information
 563  Returns : a string 0,1,2,'.'
 564  Args    : on set, one of 0,1,2,'.' or a Bio::Annotation::SimpleValue
 565            object holding one of 0,1,2,'.' as its value.
 566
 567 =cut
 568
 569 sub frame {
 570   my $self = shift;
 571   my $val = shift;
 572
 573   if(defined($val)){
 574       my $term = undef;
 575       if (!ref($val)) {
 576           $term = Bio::Annotation::SimpleValue->new(-value => $val);
 577       } elsif (ref($val) && $val->isa('Bio::Annotation::SimpleValue')) {
 578           $term = $val;
 579       }
 580       if (!defined($term) || ($term->value !~ /^[0-2.]$/)) {
 581           $self->throw("'$val' is not a valid frame");
 582       }
 583       $self->remove_Annotations('frame');
 584       $self->add_Annotation('frame', $term);
 585   }
 586
 587   $self->frame('.') unless $self->get_Annotations('frame'); # make sure we always have something
 588
 589   return ($self->get_Annotations('frame'))[0]->value;
 590 }
 591
 592 ############################################################
 593
 594 =head1 SHORTCUT METHODS TO ACCESS Bio::AnnotatableI INTERFACE METHODS
 595
 596 =cut
 597
 598 =head2 add_Annotation()
 599
 600  Usage   :
 601  Function: $obj->add_Annotation() is a shortcut to $obj->annotation->add_Annotation
 602  Returns :
 603  Args    :
 604
 605 =cut
 606
 607 sub add_Annotation {
 608   my ($self,@args) = @_;
 609   return $self->annotation->add_Annotation(@args);
 610 }
 611
 612 =head2 remove_Annotations()
 613
 614  Usage   :
 615  Function: $obj->remove_Annotations() is a shortcut to $obj->annotation->remove_Annotations
 616  Returns :
 617  Args    :
 618
 619 =cut
 620
 621 sub remove_Annotations {
 622   my ($self,@args) = @_;
 623   return $self->annotation->remove_Annotations(@args);
 624 }
 625
 626 ############################################################
 627
 628 =head1 INTERFACE METHODS FOR Bio::SeqFeatureI
 629
 630 Note that no methods are deprecated.  Any SeqFeatureI methods must return
 631 strings (no objects).
 632
 633 =cut
 634
 635 =head2 display_name()
 636
 637 =cut
 638
 639 sub display_name {
 640   my $self = shift;
 641   return $self->name(@_);
 642 }
 643
 644 =head2 primary_tag()
 645
 646 =cut
 647
 648 sub primary_tag {
 649   my $self = shift;
 650   if (@_) {
 651     my $val = shift;
 652     my $term;
 653     if(!ref($val) && $val){
 654       #we have a plain text annotation coming in.  try to map it to SOFA.
 655
 656       our %__type_cache; #a little cache of plaintext types we've already seen
 657
 658       #clear our cache if it gets too big
 659       if(scalar(keys %__type_cache) > MAX_TYPE_CACHE_MEMBERS) {
 660         %__type_cache = ();
 661       }
 662
 663       #set $term to either a cached value, or look up a new one, throwing
 664       #up if not found
 665       my $anntext = $val;
 666       if ($__type_cache{$anntext}) {
 667         $term = $__type_cache{$anntext};
 668       } else {
 669         my $sofa = Bio::Ontology::OntologyStore->get_instance->get_ontology('Sequence Ontology OBO');
 670         my ($soterm) = $anntext =~ /^\D+:\d+$/ #does it look like an ident?
 671           ? ($sofa->find_terms(-identifier => $anntext))[0] #yes, lookup by ident
 672           : ($sofa->find_terms(-name => $anntext))[0];      #no, lookup by name
 673         #throw if it's not in SOFA
 674         unless($soterm){
 675           $self->throw("couldn't find a SOFA term matching type '$val'.");
 676         }
 677         my $newterm = Bio::Annotation::OntologyTerm->new;
 678         $newterm->term($soterm);
 679         $term = $newterm;
 680       }
 681
 682       $self->type($term);
 683     }
 684   }
 685
 686   my $t = $self->type() || return;
 687   return $t->name;
 688 }
 689
 690 =head2 source_tag()
 691
 692 =cut
 693
 694 sub source_tag {
 695   my $self = shift;
 696   if (@_) {
 697     my $val = shift;
 698     if(!ref($val) && $val){
 699       my $term = Bio::Annotation::SimpleValue->new(-value => uri_unescape($val));
 700       $self->source($term);
 701     }
 702   }
 703   my $t = $self->source() || return;
 704   return $t->display_text;
 705 }
 706
 707
 708 =head2 attach_seq()
 709
 710  Usage   : $sf->attach_seq($seq)
 711  Function: Attaches a Bio::Seq object to this feature. This
 712            Bio::Seq object is for the *entire* sequence: ie
 713            from 1 to 10000
 714  Returns : TRUE on success
 715  Args    : a Bio::PrimarySeqI compliant object
 716
 717 =cut
 718
 719 sub attach_seq {
 720    my ($self, $seq) = @_;
 721
 722    if ( ! ($seq && ref($seq) && $seq->isa("Bio::PrimarySeqI")) ) {
 723        $self->throw("Must attach Bio::PrimarySeqI objects to SeqFeatures");
 724    }
 725
 726    $self->{'seq'} = $seq;
 727
 728    # attach to sub features if they want it
 729    foreach ( $self->get_SeqFeatures() ) {
 730        $_->attach_seq($seq);
 731    }
 732    return 1;
 733 }
 734
 735 =head2 seq()
 736
 737  Usage   : $tseq = $sf->seq()
 738  Function: returns a truncated version of seq() with bounds matching this feature
 739  Returns : sub seq (a Bio::PrimarySeqI compliant object) on attached sequence
 740            bounded by start & end, or undef if there is no sequence attached
 741  Args    : none
 742
 743 =cut
 744
 745 sub seq {
 746   my ($self) = @_;
 747
 748   return unless defined($self->entire_seq());
 749
 750   my $seq = $self->entire_seq->trunc($self->start(), $self->end());
 751
 752   if ( defined $self->strand && $self->strand == -1 ) {
 753     $seq = $seq->revcom;
 754   }
 755
 756   return $seq;
 757 }
 758
 759 =head2 entire_seq()
 760
 761  Usage   : $whole_seq = $sf->entire_seq()
 762  Function: gives the entire sequence that this seqfeature is attached to
 763  Returns : a Bio::PrimarySeqI compliant object, or undef if there is no
 764            sequence attached
 765  Args    : none
 766
 767 =cut
 768
 769 sub entire_seq {
 770   return shift->{'seq'};
 771 }
 772
 773 ############################################################
 774
 775 =head1 INTERFACE METHODS FOR Bio::RangeI
 776
 777  as inherited via Bio::SeqFeatureI
 778
 779 =cut
 780
 781 =head2 length()
 782
 783  Usage   : $feature->length()
 784  Function: Get the feature length computed as $feat->end - $feat->start + 1
 785  Returns : integer
 786  Args    : none
 787
 788 =cut
 789
 790 sub length {
 791   my $self = shift;
 792   return $self->end() - $self->start() + 1;
 793 }
 794
 795 =head2 start()
 796
 797  Usage   : $obj->start($newval)
 798  Function: Get/set on the start coordinate of the feature
 799  Returns : integer
 800  Args    : on set, new value (a scalar or undef, optional)
 801
 802 =cut
 803
 804 sub start {
 805   my ($self,$value) = @_;
 806   return $self->location->start($value);
 807 }
 808
 809 =head2 end()
 810
 811  Usage   : $obj->end($newval)
 812  Function: Get/set on the end coordinate of the feature
 813  Returns : integer
 814  Args    : on set, new value (a scalar or undef, optional)
 815
 816 =cut
 817
 818 sub end {
 819   my ($self,$value) = @_;
 820   return $self->location->end($value);
 821 }
 822
 823 =head2 strand()
 824
 825  Usage   : $strand = $feat->strand($newval)
 826  Function: get/set on strand information, being 1,-1 or 0
 827  Returns : -1,1 or 0
 828  Args    : on set, new value (a scalar or undef, optional)
 829
 830 =cut
 831
 832 sub strand {
 833   my $self = shift;
 834   return $self->location->strand(@_);
 835 }
 836
 837
 838 ############################################################
 839
 840 =head1 INTERFACE METHODS FOR Bio::FeatureHolderI
 841
 842 This includes methods for retrieving, adding, and removing
 843 features. Since this is already a feature, features held by this
 844 feature holder are essentially sub-features.
 845
 846 =cut
 847
 848 =head2 get_SeqFeatures
 849
 850  Usage   : @feats = $feat->get_SeqFeatures();
 851  Function: Returns an array of Bio::SeqFeatureI objects
 852  Returns : An array
 853  Args    : none
 854
 855 =cut
 856
 857 sub get_SeqFeatures {
 858   return @{ shift->{'sub_array'} || []};
 859 }
 860
 861 =head2 add_SeqFeature()
 862
 863  Usage   : $feat->add_SeqFeature($subfeat);
 864            $feat->add_SeqFeature($subfeat,'EXPAND')
 865  Function: adds a SeqFeature into the subSeqFeature array.
 866            with no 'EXPAND' qualifer, subfeat will be tested
 867            as to whether it lies inside the parent, and throw
 868            an exception if not.
 869
 870            If EXPAND is used, the parent''s start/end/strand will
 871            be adjusted so that it grows to accommodate the new
 872            subFeature
 873  Example :
 874  Returns : nothing
 875  Args    : a Bio::SeqFeatureI object
 876
 877 =cut
 878
 879 sub add_SeqFeature {
 880   my ($self,$val, $expand) = @_;
 881
 882   return unless $val;
 883
 884   if ((!ref($val)) || !$val->isa('Bio::SeqFeatureI') ) {
 885       $self->throw((ref($val) ? ref($val) : $val)
 886                    ." does not implement Bio::SeqFeatureI.");
 887   }
 888
 889   if($expand && ($expand eq 'EXPAND')) {
 890       $self->_expand_region($val);
 891   } else {
 892       if ( !$self->contains($val) ) {
 893           $self->warn("$val is not contained within parent feature, and expansion is not valid, ignoring.");
 894           return;
 895       }
 896   }
 897
 898   push(@{$self->{'sub_array'}},$val);
 899 }
 900
 901 =head2 remove_SeqFeatures()
 902
 903  Usage   : $obj->remove_SeqFeatures
 904  Function: Removes all sub SeqFeatures.  If you want to remove only a subset,
 905            remove that subset from the returned array, and add back the rest.
 906  Returns : The array of Bio::SeqFeatureI implementing sub-features that was
 907            deleted from this feature.
 908  Args    : none
 909
 910 =cut
 911
 912 sub remove_SeqFeatures {
 913   my ($self) = @_;
 914
 915   my @subfeats = @{$self->{'sub_array'} || []};
 916   $self->{'sub_array'} = []; # zap the array.
 917   return @subfeats;
 918 }
 919
 920 ############################################################
 921
 922 =head1 INTERFACE METHODS FOR Bio::AnnotatableI
 923
 924 =cut
 925
 926 =head2 annotation()
 927
 928  Usage   : $obj->annotation($annot_obj)
 929  Function: Get/set the annotation collection object for annotating this
 930            feature.
 931  Returns : A Bio::AnnotationCollectionI object
 932  Args    : newvalue (optional)
 933
 934 =cut
 935
 936 sub annotation {
 937     my ($obj,$value) = @_;
 938
 939     # we are smart if someone references the object and there hasn't been
 940     # one set yet
 941     if(defined $value || ! defined $obj->{'annotation'} ) {
 942         $value = Bio::Annotation::Collection->new() unless ( defined $value );
 943         $obj->{'annotation'} = $value;
 944     }
 945     return $obj->{'annotation'};
 946 }
 947
 948 ############################################################
 949
 950 =head2 location()
 951
 952  Usage   : my $location = $seqfeature->location()
 953  Function: returns a location object suitable for identifying location
 954            of feature on sequence or parent feature
 955  Returns : Bio::LocationI object
 956  Args    : [optional] Bio::LocationI object to set the value to.
 957
 958 =cut
 959
 960 sub location {
 961   my($self, $value ) = @_;
 962
 963   if (defined($value)) {
 964     unless (ref($value) and $value->isa('Bio::LocationI')) {
 965       $self->throw("object $value pretends to be a location but ".
 966                    "does not implement Bio::LocationI");
 967     }
 968     $self->{'location'} = $value;
 969   }
 970   elsif (! $self->{'location'}) {
 971     # guarantees a real location object is returned every time
 972     $self->{'location'} = Bio::Location::Simple->new();
 973   }
 974   return $self->{'location'};
 975 }
 976
 977 =head2 add_target()
 978
 979  Usage   : $seqfeature->add_target(Bio::LocatableSeq->new(...));
 980  Function: adds a target location on another reference sequence for this feature
 981  Returns : true on success
 982  Args    : a Bio::LocatableSeq object
 983
 984 =cut
 985
 986 sub add_target {
 987   my ($self,$seq) = @_;
 988   $self->throw("$seq is not a Bio::LocatableSeq, bailing out") unless ref($seq) and seq->isa('Bio::LocatableSeq');
 989   push @{ $self->{'targets'} }, $seq;
 990   return $seq;
 991 }
 992
 993 =head2 each_target()
 994
 995  Usage   : @targets = $seqfeature->each_target();
 996  Function: Returns a list of Bio::LocatableSeqs which are the locations of this object.
 997            To obtain the "primary" location, see L</location()>.
 998  Returns : a list of 0..N Bio::LocatableSeq objects
 999  Args    : none
1000
1001 =cut
1002
1003 sub each_target {
1004   my ($self) = @_;
1005   return $self->{'targets'} ? @{ $self->{'targets'} } : ();
1006 }
1007
1008 =head2 _expand_region
1009
1010  Title   : _expand_region
1011  Usage   : $self->_expand_region($feature);
1012  Function: Expand the total region covered by this feature to
1013            accomodate for the given feature.
1014
1015            May be called whenever any kind of subfeature is added to this
1016            feature. add_SeqFeature() already does this.
1017  Returns :
1018  Args    : A Bio::SeqFeatureI implementing object.
1019
1020 =cut
1021
1022 sub _expand_region {
1023     my ($self, $feat) = @_;
1024     if(! $feat->isa('Bio::SeqFeatureI')) {
1025         $self->warn("$feat does not implement Bio::SeqFeatureI");
1026     }
1027     # if this doesn't have start/end set - forget it!
1028     if((! defined($self->start())) && (! defined $self->end())) {
1029         $self->start($feat->start());
1030         $self->end($feat->end());
1031         $self->strand($feat->strand) unless defined($self->strand());
1032 #        $self->strand($feat->strand) unless $self->strand();
1033     } else {
1034         my $range = $self->union($feat);
1035         $self->start($range->start);
1036         $self->end($range->end);
1037         $self->strand($range->strand);
1038     }
1039 }
1040
1041 =head2 get_Annotations
1042
1043  Usage   : my $parent   = $obj->get_Annotations('Parent');
1044            my @parents = $obj->get_Annotations('Parent');
1045  Function: a wrapper around Bio::Annotation::Collection::get_Annotations().
1046  Returns : returns annotations as
1047            Bio::Annotation::Collection::get_Annotations() does, but
1048            additionally returns a single scalar in scalar context
1049            instead of list context so that if an annotation tag
1050            contains only a single value, you can do:
1051
1052            $parent = $feature->get_Annotations('Parent');
1053
1054            instead of:
1055
1056            ($parent) = ($feature->get_Annotations('Parent'))[0];
1057
1058            if the 'Parent' tag has multiple values and is called in a
1059            scalar context, the number of annotations is returned.
1060
1061  Args    : an annotation tag name.
1062
1063 =cut
1064
1065 sub get_Annotations {
1066     my $self = shift;
1067
1068     my @annotations = $self->annotation->get_Annotations(@_);
1069
1070     if(wantarray){
1071         return @annotations;
1072     } elsif(scalar(@annotations) == 1){
1073         return $annotations[0];
1074     } else {
1075         return scalar(@annotations);
1076     }
1077 }
1078
1079 =head1 Bio::SeqFeatureI implemented methods
1080
1081 These are specialized implementations of SeqFeatureI methods which call the
1082 internal Bio::Annotation::AnnotationCollection object. Just prior to the 1.5
1083 release the below methods were moved from Bio::SeqFeatureI to Bio::AnnotatableI,
1084 and having Bio::SeqFeatureI inherit Bio::AnnotatableI. This behavior forced all
1085 Bio::SeqFeatureI-implementing classes to use Bio::AnnotationI objects for any
1086 data. It is the consensus of the core developers that this be rolled back in
1087 favor of a more flexible approach by rolling back the above changes and making
1088 this class Bio::AnnotatableI. The SeqFeatureI tag-related methods are
1089 reimplemented in order to approximate the same behavior as before.
1090
1091 The methods below allow mapping of the "get_tag_values()"-style annotation
1092 access to Bio::AnnotationCollectionI. These need not be implemented in a
1093 Bio::AnnotationCollectionI compliant class, as they are built on top of the
1094 methods.  For usage, see Bio::SeqFeatureI.
1095
1096 =cut
1097
1098 =head2 has_tag
1099
1100 =cut
1101
1102 sub has_tag {
1103   my ($self,$tag) = @_;
1104   return scalar($self->annotation->get_Annotations($tag));
1105 }
1106
1107 =head2 add_tag_value
1108
1109 =cut
1110
1111 sub add_tag_value {
1112   my ($self,$tag,@vals) = @_;
1113
1114   foreach my $val (@vals){
1115     my $class = $tagclass{$tag}   || $tagclass{__DEFAULT__};
1116     my $slot  = $tag2text{$class};
1117
1118     my $a = $class->new();
1119     $a->$slot($val);
1120
1121     $self->annotation->add_Annotation($tag,$a);
1122   }
1123
1124   return 1;
1125 }
1126
1127 =head2 get_tag_values
1128
1129  Usage   : @annotations = $obj->get_tag_values($tag)
1130  Function: returns annotations corresponding to $tag
1131  Returns : a list of scalars
1132  Args    : tag name
1133
1134 =cut
1135
1136 sub get_tag_values {
1137     my ($self,$tag) = @_;
1138     if(!$tagclass{$tag} && $self->annotation->get_Annotations($tag)){
1139         #new tag, haven't seen it yet but it exists.  add to registry
1140         my($proto) = $self->annotation->get_Annotations($tag);
1141         # we can only register if there's a method known for obtaining the value
1142         if (exists($tag2text{ref($proto)})) {
1143             $tagclass{$tag} = ref($proto);
1144         }
1145     }
1146
1147     my $slot  = $tag2text{ $tagclass{$tag} || $tagclass{__DEFAULT__} };
1148
1149     return map { $_->$slot } $self->annotation->get_Annotations($tag);
1150 }
1151
1152 =head2 get_tagset_values
1153
1154  Usage   : @annotations = $obj->get_tagset_values($tag1,$tag2)
1155  Function: returns annotations corresponding to a list of tags.
1156            this is a convenience method equivalent to multiple calls
1157            to get_tag_values with each tag in the list.
1158  Returns : a list of Bio::AnnotationI objects.
1159  Args    : a list of tag names
1160
1161 =cut
1162
1163 sub get_tagset_values {
1164   my ($self,@tags) = @_;
1165   my @r = ();
1166   foreach my $tag (@tags){
1167     my $slot  = $tag2text{ $tagclass{$tag} || $tagclass{__DEFAULT__} };
1168     push @r, map { $_->$slot } $self->annotation->get_Annotations($tag);
1169   }
1170   return @r;
1171 }
1172
1173 =head2 get_all_tags
1174
1175  Usage   : @tags = $obj->get_all_tags()
1176  Function: returns a list of annotation tag names.
1177  Returns : a list of tag names
1178  Args    : none
1179
1180 =cut
1181
1182 sub get_all_tags {
1183   my ($self,@args) = @_;
1184   return $self->annotation->get_all_annotation_keys(@args);
1185 }
1186
1187 =head2 remove_tag
1188
1189  Usage   : See remove_Annotations().
1190  Function:
1191  Returns :
1192  Args    :
1193  Note    : Contrary to what the name suggests, this method removes
1194            all annotations corresponding to $tag, not just a
1195            single anntoation.
1196
1197 =cut
1198
1199 sub remove_tag {
1200   my ($self,@args) = @_;
1201   return $self->annotation->remove_Annotations(@args);
1202 }
1203
1204 1;