Bio/SeqFeature/Lite.pm

   1 package Bio::SeqFeature::Lite;
   2
   3 =head1 NAME
   4
   5 Bio::SeqFeature::Lite - Lightweight Bio::SeqFeatureI class
   6
   7 =head1 SYNOPSIS
   8
   9  # create a simple feature with no internal structure
  10  $f = Bio::SeqFeature::Lite->new(-start => 1000,
  11                                   -stop  => 2000,
  12                                   -type  => 'transcript',
  13                                   -name  => 'alpha-1 antitrypsin',
  14                                   -desc  => 'an enzyme inhibitor',
  15                                  );
  16
  17  # create a feature composed of multiple segments, all of type "similarity"
  18  $f = Bio::SeqFeature::Lite->new(-segments => [[1000,1100],[1500,1550],[1800,2000]],
  19                                   -name     => 'ABC-3',
  20                                   -type     => 'gapped_alignment',
  21                                   -subtype  => 'similarity');
  22
  23  # build up a gene exon by exon
  24  $e1 = Bio::SeqFeature::Lite->new(-start=>1,-stop=>100,-type=>'exon');
  25  $e2 = Bio::SeqFeature::Lite->new(-start=>150,-stop=>200,-type=>'exon');
  26  $e3 = Bio::SeqFeature::Lite->new(-start=>300,-stop=>500,-type=>'exon');
  27  $f  = Bio::SeqFeature::Lite->new(-segments=>[$e1,$e2,$e3],-type=>'gene');
  28
  29 =head1 DESCRIPTION
  30
  31 This is a simple Bio::SeqFeatureI-compliant object that is compatible
  32 with Bio::Graphics::Panel.  With it you can create lightweight feature
  33 objects for drawing.
  34
  35 All methods are as described in L<Bio::SeqFeatureI> with the following additions:
  36
  37 =head2 The new() Constructor
  38
  39  $feature = Bio::SeqFeature::Lite->new(@args);
  40
  41 This method creates a new feature object.  You can create a simple
  42 feature that contains no subfeatures, or a hierarchically nested object.
  43
  44 Arguments are as follows:
  45
  46   -seq_id      the reference sequence
  47   -start       the start position of the feature
  48   -end         the stop position of the feature
  49   -stop        an alias for end
  50   -name        the feature name (returned by seqname())
  51   -type        the feature type (returned by primary_tag())
  52   -primary_tag the same as -type
  53   -source      the source tag
  54   -score       the feature score (for GFF compatibility)
  55   -desc        a description of the feature
  56   -segments    a list of subfeatures (see below)
  57   -subtype     the type to use when creating subfeatures
  58   -strand      the strand of the feature (one of -1, 0 or +1)
  59   -phase       the phase of the feature (0..2)
  60   -seq         a dna or protein sequence string to attach to feature
  61   -id          an alias for -name
  62   -seqname     an alias for -name
  63   -display_id  an alias for -name
  64   -display_name an alias for -name  (do you get the idea the API has changed?)
  65   -primary_id  unique database ID
  66   -url         a URL to link to when rendered with Bio::Graphics
  67   -attributes  a hashref of tag value attributes, in which the key is the tag
  68                and the value is an array reference of values
  69   -factory     a reference to a feature factory, used for compatibility with
  70                more obscure parts of Bio::DB::GFF
  71
  72 The subfeatures passed in -segments may be an array of
  73 Bio::SeqFeature::Lite objects, or an array of [$start,$stop]
  74 pairs. Each pair should be a two-element array reference.  In the
  75 latter case, the feature type passed in -subtype will be used when
  76 creating the subfeatures.
  77
  78 If no feature type is passed, then it defaults to "feature".
  79
  80 =head2 Non-SeqFeatureI methods
  81
  82 A number of new methods are provided for compatibility with
  83 Ace::Sequence, which has a slightly different API from SeqFeatureI:
  84
  85 =over 4
  86
  87 =item url()
  88
  89 Get/set the URL that the graphical rendering of this feature will link to.
  90
  91 =item add_segment(@segments)
  92
  93 Add one or more segments (a subfeature).  Segments can either be
  94 Feature objects, or [start,stop] arrays, as in the -segments argument
  95 to new().  The feature endpoints are automatically adjusted.
  96
  97 =item segments()
  98
  99 An alias for sub_SeqFeature().
 100
 101 =item get_SeqFeatures()
 102
 103 Alias for sub_SeqFeature()
 104
 105 =item get_all_SeqFeatures()
 106
 107 Alias for sub_SeqFeature()
 108
 109 =item merged_segments()
 110
 111 Another alias for sub_SeqFeature().
 112
 113 =item stop()
 114
 115 An alias for end().
 116
 117 =item name()
 118
 119 An alias for seqname().
 120
 121 =item exons()
 122
 123 An alias for sub_SeqFeature() (you don't want to know why!)
 124
 125 =back
 126
 127 =cut
 128
 129 use strict;
 130
 131 use base qw(Bio::Root::Root Bio::SeqFeatureI Bio::LocationI Bio::SeqI);
 132
 133 *stop        = \&end;
 134 *info        = \&name;
 135 *seqname     = \&name;
 136 *exons       = *sub_SeqFeature = *merged_segments = \&segments;
 137 *get_all_SeqFeatures = *get_SeqFeatures = \&segments;
 138 *method         = \&primary_tag;
 139 *source         = \&source_tag;
 140 *get_tag_values = \&each_tag_value;
 141 *add_SeqFeature = \&add_segment;
 142 *get_all_tags   = \&all_tags;
 143 *abs_ref        = \&ref;
 144
 145 # implement Bio::SeqI and FeatureHolderI interface
 146
 147 sub primary_seq { return $_[0] }
 148 sub annotation {
 149     my ($obj,$value) = @_;
 150     if( defined $value ) {
 151         $obj->throw("object of class ".ref($value)." does not implement ".
 152                     "Bio::AnnotationCollectionI. Too bad.")
 153             unless $value->isa("Bio::AnnotationCollectionI");
 154         $obj->{'_annotation'} = $value;
 155     } elsif( ! defined $obj->{'_annotation'}) {
 156         $obj->{'_annotation'} = Bio::Annotation::Collection->new();
 157     }
 158     return $obj->{'_annotation'};
 159 }
 160 sub species {
 161     my ($self, $species) = @_;
 162     if ($species) {
 163         $self->{'species'} = $species;
 164     } else {
 165         return $self->{'species'};
 166     }
 167 }
 168 sub is_remote { return }
 169 sub feature_count { return scalar @{shift->{segments} || []} }
 170
 171 sub target { return; }
 172 sub hit    { shift->target }
 173
 174 sub type {
 175   my $self = shift;
 176   my $method = $self->primary_tag;
 177   my $source = $self->source_tag;
 178   return $source ne '' ? "$method:$source" : $method;
 179 }
 180
 181 # usage:
 182 # Bio::SeqFeature::Lite->new(
 183 #                         -start => 1,
 184 #                         -end   => 100,
 185 #                         -name  => 'fred feature',
 186 #                         -strand => +1);
 187 #
 188 # Alternatively, use -segments => [ [start,stop],[start,stop]...]
 189 # to create a multisegmented feature.
 190 sub new {
 191   my $class= shift;
 192   $class = ref($class) if ref $class;
 193   my %arg = @_;
 194
 195   my $self = bless {},$class;
 196
 197   $arg{-strand} ||= 0;
 198   if ($arg{-strand} =~ /^[\+\-\.]$/){
 199         ($arg{-strand} eq "+") && ($self->{strand} = '1');
 200         ($arg{-strand} eq "-") && ($self->{strand} = '-1');
 201         ($arg{-strand} eq ".") && ($self->{strand} = '0');
 202   } else {
 203           $self->{strand}  = $arg{-strand} ? ($arg{-strand} >= 0 ? +1 : -1) : 0;
 204   }
 205   $self->{name}    = $arg{-name}   || $arg{-seqname} || $arg{-display_id}
 206     || $arg{-display_name} || $arg{-id};
 207   $self->{type}    = $arg{-type}   || $arg{-primary_tag} || 'feature';
 208   $self->{subtype} = $arg{-subtype} if exists $arg{-subtype};
 209   $self->{source}  = $arg{-source} || $arg{-source_tag} || '';
 210   $self->{score}   = $arg{-score}   if exists $arg{-score};
 211   $self->{start}   = $arg{-start};
 212   $self->{stop}    = exists $arg{-end} ? $arg{-end} : $arg{-stop};
 213   $self->{ref}     = $arg{-seq_id} || $arg{-ref};
 214   $self->{attributes}     = $arg{-attributes} || $arg{-tag};
 215   for my $option (qw(class url seq phase desc primary_id)) {
 216     $self->{$option} = $arg{"-$option"} if exists $arg{"-$option"};
 217   }
 218
 219   # is_circular is needed for Bio::PrimarySeqI compliance
 220   $self->{is_circular} = $arg{-is_circular} || 0;
 221
 222   # fix start, stop
 223   if (defined $self->{stop} && defined $self->{start}
 224       && $self->{stop} < $self->{start}) {
 225     @{$self}{'start','stop'} = @{$self}{'stop','start'};
 226     $self->{strand} *= -1;
 227   }
 228
 229   my @segments;
 230   if (my $s = $arg{-segments}) {
 231     # NB: when $self ISA Bio::DB::SeqFeature the following invokes
 232     # Bio::DB::SeqFeature::add_segment and not
 233     # Bio::DB::SeqFeature::add_segment (as might be expected?)
 234     $self->add_segment(@$s);
 235   }
 236
 237   $self;
 238 }
 239
 240 sub add_segment {
 241   my $self        = shift;
 242   my $type = $self->{subtype} || $self->{type};
 243   $self->{segments} ||= [];
 244   my $ref   = $self->seq_id;
 245   my $name  = $self->name;
 246   my $class = $self->class;
 247   my $source_tag = $self->source_tag;
 248
 249   my $min_start = $self->start ||  999_999_999_999;
 250   my $max_stop  = $self->end   || -999_999_999_999;
 251
 252   my @segments = @{$self->{segments}};
 253
 254   for my $seg (@_) {
 255     if (ref($seg) eq 'ARRAY') {
 256       my ($start,$stop) = @{$seg};
 257       next unless defined $start && defined $stop;  # fixes an obscure bug somewhere above us
 258       my $strand = $self->{strand};
 259
 260       if ($start > $stop) {
 261         ($start,$stop) = ($stop,$start);
 262         $strand = -1;
 263       }
 264
 265       push @segments,$self->new(-start  => $start,
 266                                 -stop   => $stop,
 267                                 -strand => $strand,
 268                                 -ref    => $ref,
 269                                 -type   => $type,
 270                                 -name   => $name,
 271                                 -class  => $class,
 272                                 -phase  => $self->{phase},
 273                                 -score  => $self->{score},
 274                                 -source_tag  => $source_tag,
 275                                 -attributes  => $self->{attributes},
 276                                );
 277       $min_start = $start if $start < $min_start;
 278       $max_stop  = $stop  if $stop  > $max_stop;
 279
 280     } elsif (ref $seg) {
 281       push @segments,$seg;
 282
 283       $min_start = $seg->start if ($seg->start && $seg->start < $min_start);
 284       $max_stop  = $seg->end   if ($seg->end && $seg->end > $max_stop);
 285     }
 286   }
 287   if (@segments) {
 288     local $^W = 0;  # some warning of an uninitialized variable...
 289     $self->{segments} = \@segments;
 290     $self->{ref}    ||= $self->{segments}[0]->seq_id;
 291     $self->{start}    = $min_start;
 292     $self->{stop}     = $max_stop;
 293   }
 294 }
 295
 296 sub segments {
 297   my $self = shift;
 298   my $s = $self->{segments} or return wantarray ? () : 0;
 299   @$s;
 300 }
 301 sub score    {
 302   my $self = shift;
 303   my $d = $self->{score};
 304   $self->{score} = shift if @_;
 305   $d;
 306 }
 307 sub primary_tag     {
 308     my $self = shift;
 309     my $d    = $self->{type};
 310     $self->{type} = shift if @_;
 311     $d;
 312 }
 313 sub name            {
 314   my $self = shift;
 315   my $d    = $self->{name};
 316   $self->{name} = shift if @_;
 317   $d;
 318 }
 319 sub seq_id          { shift->ref(@_)         }
 320 sub ref {
 321   my $self = shift;
 322   my $d = $self->{ref};
 323   $self->{ref} = shift if @_;
 324   $d;
 325 }
 326 sub start    {
 327   my $self = shift;
 328   my $d = $self->{start};
 329   $self->{start} = shift if @_;
 330   if (my $rs = $self->{refseq}) {
 331     my $strand = $rs->strand || 1;
 332     return $strand >= 0 ? ($d - $rs->start + 1) : ($rs->end - $d + 1);
 333   } else {
 334     return $d;
 335   }
 336 }
 337 sub end    {
 338   my $self = shift;
 339   my $d = $self->{stop};
 340   $self->{stop} = shift if @_;
 341   if (my $rs = $self->{refseq}) {
 342     my $strand = $rs->strand || 1;
 343     return $strand >= 0 ? ($d - $rs->start + 1) : ($rs->end - $d + 1);
 344   }
 345   $d;
 346 }
 347 sub strand {
 348   my $self = shift;
 349   my $d = $self->{strand};
 350   $self->{strand} = shift if @_;
 351   if (my $rs = $self->{refseq}) {
 352     my $rstrand = $rs->strand;
 353     return  0 unless $d;
 354     return  1 if $rstrand == $d;
 355     return -1 if $rstrand != $d;
 356   }
 357   $d;
 358 }
 359
 360 # this does nothing, but it is here for compatibility reasons
 361 sub absolute {
 362   my $self = shift;
 363   my $d = $self->{absolute};
 364   $self->{absolute} = shift if @_;
 365   $d;
 366 }
 367
 368 sub abs_start {
 369   my $self = shift;
 370   local $self->{refseq} = undef;
 371   $self->start(@_);
 372 }
 373 sub abs_end {
 374   my $self = shift;
 375   local $self->{refseq} = undef;
 376   $self->end(@_);
 377 }
 378 sub abs_strand {
 379   my $self = shift;
 380   local $self->{refseq} = undef;
 381   $self->strand(@_);
 382 }
 383
 384 sub length {
 385   my $self = shift;
 386   return $self->end - $self->start + 1;
 387 }
 388
 389 #is_circular is needed for Bio::PrimarySeqI
 390 sub is_circular {
 391   my $self = shift;
 392   my $d = $self->{is_circular};
 393   $self->{is_circular} = shift if @_;
 394   $d;
 395 }
 396
 397
 398 sub seq {
 399   my $self = shift;
 400   my $seq =  exists $self->{seq} ? $self->{seq} : '';
 401   return $seq;
 402 }
 403
 404 sub dna {
 405   my $seq = shift->seq;
 406   $seq    = $seq->seq if CORE::ref($seq);
 407   return $seq;
 408 }
 409
 410 =head2 display_name
 411
 412  Title   : display_name
 413  Usage   : $id = $obj->display_name or $obj->display_name($newid);
 414  Function: Gets or sets the display id, also known as the common name of
 415            the Seq object.
 416
 417            The semantics of this is that it is the most likely string
 418            to be used as an identifier of the sequence, and likely to
 419            have "human" readability.  The id is equivalent to the LOCUS
 420            field of the GenBank/EMBL databanks and the ID field of the
 421            Swissprot/sptrembl database. In fasta format, the >(\S+) is
 422            presumed to be the id, though some people overload the id
 423            to embed other information. Bioperl does not use any
 424            embedded information in the ID field, and people are
 425            encouraged to use other mechanisms (accession field for
 426            example, or extending the sequence object) to solve this.
 427
 428            Notice that $seq->id() maps to this function, mainly for
 429            legacy/convenience issues.
 430  Returns : A string
 431  Args    : None or a new id
 432
 433
 434 =cut
 435
 436 sub display_name { shift->name(@_) }
 437
 438 *display_id = \&display_name;
 439
 440 =head2 accession_number
 441
 442  Title   : accession_number
 443  Usage   : $unique_biological_key = $obj->accession_number;
 444  Function: Returns the unique biological id for a sequence, commonly
 445            called the accession_number. For sequences from established
 446            databases, the implementors should try to use the correct
 447            accession number. Notice that primary_id() provides the
 448            unique id for the implementation, allowing multiple objects
 449            to have the same accession number in a particular implementation.
 450
 451            For sequences with no accession number, this method should return
 452            "unknown".
 453  Returns : A string
 454  Args    : None
 455
 456
 457 =cut
 458
 459 sub accession_number {
 460     return 'unknown';
 461 }
 462
 463 =head2 alphabet
 464
 465  Title   : alphabet
 466  Usage   : if( $obj->alphabet eq 'dna' ) { /Do Something/ }
 467  Function: Returns the type of sequence being one of
 468            'dna', 'rna' or 'protein'. This is case sensitive.
 469
 470            This is not called <type> because this would cause
 471            upgrade problems from the 0.5 and earlier Seq objects.
 472
 473  Returns : a string either 'dna','rna','protein'. NB - the object must
 474            make a call of the type - if there is no type specified it
 475            has to guess.
 476  Args    : none
 477  Status  : Virtual
 478
 479
 480 =cut
 481
 482 sub alphabet{
 483     return 'dna'; # no way this will be anything other than dna!
 484 }
 485
 486
 487
 488 =head2 desc
 489
 490  Title   : desc
 491  Usage   : $seqobj->desc($string) or $seqobj->desc()
 492  Function: Sets or gets the description of the sequence
 493  Example :
 494  Returns : The description
 495  Args    : The description or none
 496
 497
 498 =cut
 499
 500 sub desc {
 501   my $self = shift;
 502   my ($d)    = $self->notes;
 503   $self->{desc} = shift if @_;
 504   $d;
 505 }
 506
 507 sub attributes {
 508   my $self = shift;
 509   if (@_) {
 510     return $self->get_tag_values(@_);
 511   } else {
 512     return $self->{attributes} ? %{$self->{attributes}} : ();
 513   }
 514 }
 515
 516 sub primary_id {
 517   my $self = shift;
 518   my $d = $self->{primary_id};
 519   $self->{primary_id} = shift if @_;
 520   return $d;
 521 #  return $d if defined $d;
 522 #  return (overload::StrVal($self) =~ /0x([a-f0-9]+)/)[0];
 523 }
 524
 525 sub notes {
 526     my $self  = shift;
 527     my $notes = $self->{desc};
 528     return $notes if defined $notes;
 529     return $self->attributes('Note');
 530 }
 531
 532 sub aliases {
 533     my $self  = shift;
 534     return $self->attributes('Alias');
 535 }
 536
 537 sub low {
 538   my $self = shift;
 539   return $self->start < $self->end ? $self->start : $self->end;
 540 }
 541
 542 sub high {
 543   my $self = shift;
 544   return $self->start > $self->end ? $self->start : $self->end;
 545 }
 546
 547 =head2 location
 548
 549  Title   : location
 550  Usage   : my $location = $seqfeature->location()
 551  Function: returns a location object suitable for identifying location
 552            of feature on sequence or parent feature
 553  Returns : Bio::LocationI object
 554  Args    : none
 555
 556 =cut
 557
 558 sub location {
 559    my $self = shift;
 560    require Bio::Location::Split unless Bio::Location::Split->can('new');
 561    my $location;
 562    if (my @segments = $self->segments) {
 563        $location = Bio::Location::Split->new();
 564        foreach (@segments) {
 565          $location->add_sub_Location($_);
 566        }
 567    } else {
 568        $location = $self;
 569    }
 570    $location;
 571 }
 572
 573 sub each_Location {
 574   my $self = shift;
 575   require Bio::Location::Simple unless Bio::Location::Simple->can('new');
 576   if (my @segments = $self->segments) {
 577     return map {
 578         Bio::Location::Simple->new(-start  => $_->start,
 579                                    -end    => $_->end,
 580                                    -strand => $_->strand);
 581       } @segments;
 582   } else {
 583     return Bio::Location::Simple->new(-start  => $self->start,
 584                                       -end    => $self->end,
 585                                       -strand => $self->strand);
 586   }
 587 }
 588
 589 =head2 location_string
 590
 591  Title   : location_string
 592  Usage   : my $string = $seqfeature->location_string()
 593  Function: Returns a location string in a format recognized by gbrowse
 594  Returns : a string
 595  Args    : none
 596
 597 This is a convenience function used by the generic genome browser. It
 598 returns the location of the feature and its subfeatures in the compact
 599 form "start1..end1,start2..end2,...".  Use
 600 $seqfeature-E<gt>location()-E<gt>toFTString() to obtain a standard
 601 GenBank/EMBL location representation.
 602
 603 =cut
 604
 605 sub location_string {
 606   my $self = shift;
 607   my @segments = $self->segments or return $self->to_FTstring;
 608   join ',',map {$_->to_FTstring} @segments;
 609 }
 610
 611 sub coordinate_policy {
 612    require Bio::Location::WidestCoordPolicy unless Bio::Location::WidestCoordPolicy->can('new');
 613    return Bio::Location::WidestCoordPolicy->new();
 614 }
 615
 616 sub min_start { shift->low }
 617 sub max_start { shift->low }
 618 sub min_end   { shift->high }
 619 sub max_end   { shift->high}
 620 sub start_pos_type { 'EXACT' }
 621 sub end_pos_type   { 'EXACT' }
 622 sub to_FTstring {
 623   my $self = shift;
 624   my $low  = $self->min_start;
 625   my $high = $self->max_end;
 626   my $strand = $self->strand;
 627   my $str = defined $strand && $strand<0 ? "complement($low..$high)" : "$low..$high";
 628   if (my $id = $self->seq_id()) {
 629     $str = $id . ":" . $str;
 630   }
 631   $str;
 632 }
 633 sub phase {
 634     my $self = shift;
 635     my $d    = $self->{phase};
 636     $self->{phase} = shift if @_;
 637     $d;
 638 }
 639
 640 sub class {
 641   my $self = shift;
 642   my $d = $self->{class};
 643   $self->{class} = shift if @_;
 644   return defined($d) ? $d : 'Sequence';  # acedb is still haunting me - LS
 645 }
 646
 647 # set GFF dumping version
 648 sub version {
 649   my $self = shift;
 650   my $d    = $self->{gff3_version} || 2;
 651   $self->{gff3_version} = shift if @_;
 652   $d;
 653 }
 654
 655 sub gff_string {
 656   my $self    = shift;
 657
 658   if ($self->version == 3) {
 659     return $self->gff3_string(@_);
 660   }
 661
 662   my $recurse = shift;
 663   my $name  = $self->name;
 664   my $class = $self->class;
 665   my $group = "$class $name" if $name;
 666   my $strand = ('-','.','+')[$self->strand+1];
 667   my $string;
 668   $string .= join("\t",
 669                   $self->ref||'.',$self->source||'.',$self->method||'.',
 670                   $self->start||'.',$self->stop||'.',
 671                   defined($self->score) ? $self->score : '.',
 672                   $strand||'.',
 673                   defined($self->phase) ? $self->phase : '.',
 674                   $group||''
 675                  );
 676   $string .= "\n";
 677   if ($recurse) {
 678     foreach ($self->sub_SeqFeature) {
 679       $string .= $_->gff_string($recurse);
 680     }
 681   }
 682   $string;
 683 }
 684
 685 # Suggested strategy for dealing with the multiple parentage issue.
 686 # First recurse through object tree and record parent tree.
 687 # Then recurse again, skipping objects we've seen before.
 688 sub gff3_string {
 689     my ($self,$recurse,$parent_tree,$seenit,$force_id) = @_;
 690     $parent_tree ||= {};
 691     $seenit      ||= {};
 692     my @rsf      =   ();
 693     my @parent_ids;
 694
 695     if ($recurse) {
 696         $self->_traverse($parent_tree) unless %$parent_tree;  # this will record parents of all children
 697         my $primary_id = defined $force_id ? $force_id : $self->_real_or_dummy_id;
 698
 699         return if $seenit->{$primary_id}++;
 700
 701         @rsf = $self->get_SeqFeatures;
 702         if (@rsf) {
 703             # Detect case in which we have a split location feature. In this case we
 704             # skip to the grandchildren and trick them into thinking that our parent is theirs.
 705             my %types = map {$_->primary_tag=>1} @rsf;
 706             my @types = keys %types;
 707             if (@types == 1 && $types[0] eq $self->primary_tag) {
 708                 return join ("\n",map {$_->gff3_string(1,$parent_tree,{},$primary_id)} @rsf);
 709             }
 710         }
 711
 712         @parent_ids = keys %{$parent_tree->{$primary_id}};
 713     }
 714
 715     my $group      = $self->format_attributes(\@parent_ids,$force_id);
 716     my $name       = $self->name;
 717
 718     my $class = $self->class;
 719     my $strand = ('-','.','+')[$self->strand+1];
 720     my $p = join("\t",
 721                  $self->seq_id||'.',
 722                  $self->source||'.',
 723                  $self->method||'.',
 724                  $self->start||'.',
 725                  $self->stop||'.',
 726                  defined($self->score) ? $self->score : '.',
 727                  $strand||'.',
 728                  defined($self->phase) ? $self->phase : '.',
 729                  $group||'');
 730     return join("\n",
 731                 $p,
 732                 map {$_->gff3_string(1,$parent_tree,$seenit)} @rsf);
 733 }
 734
 735 sub _real_or_dummy_id {
 736     my $self = shift;
 737     my $id   = $self->primary_id;
 738     return $id if defined $id;
 739     return return (overload::StrVal($self) =~ /0x([a-f0-9]+)/)[0];
 740 }
 741
 742 sub _traverse {
 743     my $self   = shift;
 744     my $tree   = shift;  # tree => {$child}{$parent} = 1
 745     my $parent = shift;
 746     my $id     = $self->_real_or_dummy_id;
 747     defined $id or return;
 748     $tree->{$id}{$parent->_real_or_dummy_id}++ if $parent;
 749     $_->_traverse($tree,$self) foreach $self->get_SeqFeatures;
 750 }
 751
 752 sub db { return }
 753
 754 sub source_tag {
 755   my $self = shift;
 756   my $d = $self->{source};
 757   $self->{source} = shift if @_;
 758   $d;
 759 }
 760
 761 # This probably should be deleted.  Not sure why it's here, but might
 762 # have been added for Ace::Sequence::Feature-compliance.
 763 sub introns {
 764   my $self = shift;
 765   return;
 766 }
 767
 768 sub has_tag {
 769     my $self = shift;
 770     my $tag  = shift;
 771     return exists $self->{attributes}{$tag};
 772 }
 773
 774 sub escape {
 775   my $self     = shift;
 776   my $toencode = shift;
 777   $toencode    =~ s/([^a-zA-Z0-9_.:?^*\(\)\[\]@!+-])/uc sprintf("%%%02x",ord($1))/eg;
 778   $toencode;
 779 }
 780
 781 sub all_tags {
 782   my $self = shift;
 783   return keys %{$self->{attributes}};
 784 }
 785
 786 sub add_tag_value {
 787   my $self = shift;
 788   my ($tag_name,@tag_values) = @_;
 789   push @{$self->{attributes}{$tag_name}},@tag_values;
 790 }
 791
 792 sub remove_tag {
 793   my $self = shift;
 794   my $tag_name = shift;
 795   delete $self->{attributes}{$tag_name};
 796 }
 797
 798 sub each_tag_value {
 799   my $self = shift;
 800   my $tag  = shift;
 801   my $value = $self->{attributes}{$tag} or return;
 802   my $ref = CORE::ref $value;
 803   return $ref && $ref eq 'ARRAY' ? @{$self->{attributes}{$tag}}
 804                                  : $self->{attributes}{$tag};
 805 }
 806
 807 sub get_Annotations {
 808   my $self = shift;
 809   my $tag  = shift;
 810   my @values = $self->get_tag_values($tag);
 811   return $values[0] if @values == 1;
 812   return @values;
 813 }
 814
 815 sub format_attributes {
 816   my $self        = shift;
 817   my $parent      = shift;
 818   my $fallback_id = shift;
 819
 820   my @tags = $self->get_all_tags;
 821   my @result;
 822   for my $t (@tags) {
 823     my @values = $self->get_tag_values($t);
 824     push @result,join '=',$self->escape($t),join(',', map {$self->escape($_)} @values) if @values;
 825   }
 826   #my $id        = $self->escape($self->_real_or_dummy_id) || $fallback_id;
 827   my $id        = $fallback_id || $self->escape($self->_real_or_dummy_id);
 828
 829   my $parent_id;
 830   if (@$parent) {
 831       $parent_id  = join (',',map {$self->escape($_)} @$parent);
 832   }
 833
 834   my $name = $self->display_name;
 835   unshift @result,"ID=".$id                                    if defined $id;
 836   unshift @result,"Parent=".$parent_id                         if defined $parent_id;
 837   unshift @result,"Name=".$self->escape($name)                 if defined $name;
 838   return join ';',@result;
 839 }
 840
 841 =head2 clone
 842
 843  Title   : clone
 844  Usage   : my $feature = $seqfeature->clone
 845  Function: Create a deep copy of the feature
 846  Returns : A copy of the feature
 847  Args    : none
 848
 849 =cut
 850
 851 sub clone {
 852   my $self  = shift;
 853   my %clone  = %$self;
 854   # overwrite attributes
 855   my $clone = bless \%clone,CORE::ref($self);
 856   $clone{attributes} = {};
 857   for my $k (keys %{$self->{attributes}}) {
 858     @{$clone{attributes}{$k}} = @{$self->{attributes}{$k}};
 859   }
 860   return $clone;
 861 }
 862
 863 =head2 refseq
 864
 865  Title   : refseq
 866  Usage   : $ref = $s->refseq([$newseq] [,$newseqclass])
 867  Function: get/set reference sequence
 868  Returns : current reference sequence
 869  Args    : new reference sequence and class (optional)
 870  Status  : Public
 871
 872 This method will get or set the reference sequence.  Called with no
 873 arguments, it returns the current reference sequence.  Called with any
 874 Bio::SeqFeatureI object that provides the seq_id(), start(), end() and
 875 strand() methods.
 876
 877 The method will generate an exception if you attempt to set the
 878 reference sequence to a sequence that has a different seq_id from the
 879 current feature.
 880
 881 =cut
 882
 883 sub refseq {
 884   my $self = shift;
 885   my $d    = $self->{refseq};
 886   if (@_) {
 887     my $newref = shift;
 888     $self->throw("attempt to set refseq using a feature that does not share the same seq_id")
 889       unless $newref->seq_id eq $self->seq_id;
 890     $self->{refseq} = $newref;
 891   }
 892   return $d;
 893 }
 894
 895 sub DESTROY { }
 896
 897 1;
 898
 899 __END__
 900
 901 =head1 SEE ALSO
 902
 903 L<Bio::Graphics::Feature>
 904
 905 =head1 AUTHOR
 906
 907 Lincoln Stein E<lt>lstein@cshl.eduE<gt>.
 908
 909 Copyright (c) 2006 Cold Spring Harbor Laboratory
 910
 911 This library is free software; you can redistribute it and/or modify
 912 it under the same terms as Perl itself.  See DISCLAIMER.txt for
 913 disclaimers of warranty.
 914
 915 =cut