Bio/SeqFeature/Lite.pm

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