← Back to branch summary

~ubuntu-branches/ubuntu/saucy/bioperl/saucy-proposed

« back to all changes in this revision

Viewing changes to Bio/DB/SeqFeature/NormalizedFeature.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2009-03-10 07:19:11 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20090310071911-fukqzw54pyb1f0bd
Tags: 1.6.0-2
https://launchpad.net/bugs/324001
* Removed patch system (not used):
  - removed instuctions in debian/rules;
  - removed quilt from Build-Depends in debian/control.
* Re-enabled tests:
  - uncommented test command in debian/rules;
  - uncommented previously missing build-dependencies in debian/control.
  - Re-enabled tests and uncommented build-dependencies accordingly.
* Removed libmodule-build-perl and libtest-harness-perl from
  Build-Depends-Indep (provided by perl-modules).
* Better cleaning of empty directories using find -type d -empty -delete
  instead of rmdir in debian/rules (LP: #324001).

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/DB/SeqFeature/NormalizedFeature.pm
1
1
package Bio::DB::SeqFeature::NormalizedFeature;
2
2
 
3
 
# $Id: NormalizedFeature.pm,v 1.13.4.5 2006/11/08 17:25:54 sendu Exp $
 
3
# $Id: NormalizedFeature.pm 15119 2008-12-09 02:08:10Z lstein $
4
4
 
5
5
=head1 NAME
6
6
 
58
58
 
59
59
use strict;
60
60
use Carp 'croak';
61
 
use base 'Bio::Graphics::FeatureBase';
 
61
use base 'Bio::SeqFeature::Lite';
62
62
use base 'Bio::DB::SeqFeature::NormalizedFeatureI';
63
63
use overload '""' => \&as_string,
64
64
              eq  => \&eq,
176
176
    return Bio::PrimarySeq->new(-seq => $store->fetch_sequence($self->seq_id,$start,$end) || '',
177
177
                                -id  => $self->display_name);
178
178
  } else {
179
 
    return $self->SUPER::seq($self->seq_id,$start,$end);
 
179
      return $self->SUPER::seq($self->seq_id,$start,$end);
180
180
  }
181
181
}
182
182
 
409
409
  my @segments   = $self->_create_subfeatures($normalized,@_);
410
410
 
411
411
  # fix boundaries
412
 
  $self->_fix_boundaries(\@segments,$normalized);
 
412
  $self->_fix_boundaries(\@segments);
413
413
 
414
414
  # freakish fixing of our non-standard Target attribute
415
415
  $self->_fix_target(\@segments);
416
416
 
 
417
  for my $seg (@segments) {
 
418
    my $id  = $normalized ? $seg->primary_id : $seg;
 
419
    defined $id or $self->throw("No primary ID when there should be");
 
420
    push @{$self->{segments}},$id;
 
421
  };
 
422
 
417
423
  $self->update if $self->primary_id; # write us back to disk
418
424
}
419
425
 
420
426
sub _fix_boundaries {
421
 
  my $self     = shift;
422
 
  my ($segments,$normalized) = @_;
 
427
  my $self       = shift;
 
428
  my $segments   = shift;
 
429
  my $normalized = shift;
423
430
 
424
431
  my $min_start = $self->start ||  999_999_999_999;
425
432
  my $max_stop  = $self->end   || -999_999_999_999;
427
434
  for my $seg (@$segments) {
428
435
    $min_start     = $seg->start if $seg->start < $min_start;
429
436
    $max_stop      = $seg->end   if $seg->end   > $max_stop;
430
 
    my $id_or_seg  = $normalized ? $seg->primary_id : $seg;
431
 
    defined $id_or_seg or $self->throw("No primary ID when there should be");
432
 
    push @{$self->{segments}},$id_or_seg;
433
437
  }
434
438
 
435
439
  # adjust our boundaries, etc.
442
446
sub _fix_target {
443
447
  my $self = shift;
444
448
  my $segs = shift;
 
449
  my $normalized = shift;  # ignored for now
445
450
 
446
451
  # freakish fixing of our non-standard Target attribute
447
452
  if (my $t = ($self->attributes('Target'))[0]) {
448
453
    my ($seqid,$tstart,$tend,$strand) = split /\s+/,$t;
449
 
    my $min_tstart = $tstart;
450
 
    my $max_tend   = $tend;
451
 
    for my $seg (@$segs) {
452
 
      my $st = ($seg->attributes('Target'))[0] or next;
453
 
      (undef,$tstart,$tend) = split /\s+/,$st;
454
 
      $min_tstart     = $tstart if $tstart < $min_tstart;
455
 
      $max_tend       = $tend   if $tend   > $max_tend;
456
 
    }
457
 
    if ($min_tstart < $tstart or $max_tend > $tend) {
458
 
      $self->{attributes}{Target}[0] = join ' ',($seqid,$min_tstart,$max_tend,$strand||'');
 
454
    if (defined $tstart && defined $tend) {
 
455
        my $min_tstart = $tstart;
 
456
        my $max_tend   = $tend;
 
457
        for my $seg (@$segs) {
 
458
            my $st = ($seg->attributes('Target'))[0] or next;
 
459
            (undef,$tstart,$tend) = split /\s+/,$st;
 
460
            next unless defined $tstart && defined $tend;
 
461
            $min_tstart     = $tstart if $tstart < $min_tstart;
 
462
            $max_tend       = $tend   if $tend   > $max_tend;
 
463
        }
 
464
        if ($min_tstart < $tstart or $max_tend > $tend) {
 
465
            $self->{attributes}{Target}[0] = join ' ',($seqid,$min_tstart,$max_tend,$strand||'');
 
466
        }
459
467
    }
460
468
  }
461
469
}
465
473
  my $self   = shift;
466
474
  my $parent = shift;
467
475
  my $load_id   = $self->load_id || '';
468
 
  my ($target)  = split /\s+/,($self->attributes('Target'))[0];
469
 
  $target ||= '';
 
476
  my $targobj = ($self->attributes('Target'))[0];
 
477
  # was getting an 'Use of uninitialized value with split' here, changed to cooperate -cjf 7/10/07
 
478
  my ($target)  = $targobj ? split /\s+/,($self->attributes('Target'))[0] : ('');
470
479
  my @tags = $self->all_tags;
471
480
  my @result;
472
481
  for my $t (@tags) {
473
482
    my @values = $self->each_tag_value($t);
474
 
    @values = grep {$_ ne $load_id && $_ ne $target} @values if $t eq 'Alias';
 
483
 
 
484
    # This line prevents Alias from showing up if it matches the load id, but this is not good
 
485
    # @values = grep {$_ ne $load_id && $_ ne $target} @values if $t eq 'Alias';
 
486
 
475
487
    # these are hacks, which we don't want to appear in the file
476
488
    next if $t eq 'load_id';
477
489
    next if $t eq 'parent_id';
 
490
 
478
491
    foreach (@values) { s/\s+$// } # get rid of trailing whitespace
479
 
 
480
 
    push @result,join '=',$self->escape($t),$self->escape($_) foreach @values;
 
492
    push @result,join '=',$self->escape($t),join(',', map {$self->escape($_)} @values) if @values;
481
493
  }
482
494
  my $id   = $self->primary_id;
483
495
  my $name = $self->display_name;
484
 
  push @result,"ID=".$self->escape($id)                     if defined $id;
485
 
  push @result,"Parent=".$self->escape($parent->primary_id) if defined $parent;
486
 
  push @result,"Name=".$self->escape($name)                   if defined $name;
 
496
  unshift @result,"ID=".$self->escape($id)                     if defined $id;
 
497
  unshift @result,"Parent=".$self->escape($parent->primary_id) if defined $parent;
 
498
  unshift @result,"Name=".$self->escape($name)                   if defined $name;
487
499
  return join ';',@result;
488
500
}
489
501
 
495
507
  my $ref   = $self->seq_id;
496
508
  my $name  = $self->name;
497
509
  my $class = $self->class;
498
 
  my $store = $self->object_store
499
 
    or $self->throw("Feature must be associated with a Bio::DB::SeqFeature::Store database before attempting to add subfeatures");
500
 
 
501
 
  my $index_subfeatures_policy = $store->index_subfeatures;
 
510
  my $store = $self->object_store;
 
511
  my $source = $self->source;
 
512
 
 
513
  if ($normalized) {
 
514
    $store or $self->throw("Feature must be associated with a Bio::DB::SeqFeature::Store database before attempting to add subfeatures to a normalized object");
 
515
  }
 
516
 
 
517
  my $index_subfeatures_policy = eval{$store->index_subfeatures};
502
518
 
503
519
  my @segments;
504
520
 
529
545
                                -type   => $type,
530
546
                                -name   => $name,
531
547
                                -class  => $class,
 
548
                                -source => $source,
532
549
                               );
533
550
    }
534
551
 
543
560
                         -primary_tag => $seg->primary_tag,
544
561
                         -source_tag  => $seg->source,
545
562
                         -score       => $score,
 
563
                         -source => $source,
546
564
                        );
547
565
      for my $tag ($seg->get_all_tags) {
548
566
        my @values = $seg->get_tag_values($tag);
693
711
sub as_string {
694
712
  my $self = shift;
695
713
  return overload::StrVal($self) unless $self->overloaded_names;
696
 
  my $name   = $self->display_name || $self->load_id || "id=".$self->primary_id;
 
714
  my $name   = $self->display_name || $self->load_id;
 
715
  $name    ||= "id=".$self->primary_id if $self->primary_id;
 
716
  $name    ||= "<unnamed>";
697
717
  my $method = $self->primary_tag;
698
718
  my $source= $self->source_tag;
699
719
  my $type  = $source ? "$method:$source" : $method;