jpred/lib/Sequence.pm

   1 package Sequence;
   2
   3 use strict;
   4 use warnings;
   5 use Carp;
   6 use base qw(Root);
   7
   8 sub id {
   9         my ($self, $id) = @_;
  10         defined $id ?
  11                 $self->{__PACKAGE__."id"} = $id :
  12                 return $self->{__PACKAGE__."id"};
  13 }
  14
  15 sub seq {
  16         my ($self, @entries) = @_;
  17         if (@entries) { $self->{__PACKAGE__."seq"} = [ @entries ] }
  18         else {
  19                 if (wantarray) {
  20                         return defined $self->{__PACKAGE__."seq"} ?
  21                                 @{ $self->{__PACKAGE__."seq"} } :
  22                                 ();
  23                 }
  24                 else { return $self->{__PACKAGE__."seq"} }
  25         }
  26 }
  27
  28 sub length {
  29         my ($self) = @_;
  30         return scalar @{ [ $self->seq ] };
  31 }
  32
  33 #sub numeric {
  34 #       my ($self, $set) = @_;
  35 #       return $set ?
  36 #               $self->{__PACKAGE__."numeric"} = $set :
  37 #               $self->{__PACKAGE__."numeric"};
  38 #}
  39 #
  40 #use Scalar::Util qw(looks_like_number);
  41 #sub seq_compress {
  42 #       my ($self, @entries) = @_;
  43 #       if (@entries) {
  44 #               my $numeric = grep { looks_like_number $_ } @entries;
  45 #               if ($numeric != 0 && $numeric != @entries) {
  46 #                       die "Can't compress both numeric and non-numeric data";
  47 #               }
  48 #
  49 #               if ($numeric) {
  50 #                       $self->numeric(1);
  51 #                       $self->seq(pack "d*", @entries)
  52 #               }
  53 #               else { $self->seq(join '', @entries) }
  54 #       }
  55 #       else {
  56 #               return $self->seq
  57 #       }
  58 #}
  59
  60 sub sub_seq {
  61         my ($self, @segments) = @_;
  62
  63         my $package = ref $self;
  64
  65         return $self->seq unless @segments;
  66         confess "Passed an uneven number of segments" unless @segments % 2 == 0;
  67
  68         {
  69                 my %segments = @segments;
  70                 # Find out if there are overlapping segments
  71                 for my $pri (sort keys %segments) {
  72                         for my $test (sort keys %segments) {
  73                                 next if $pri == $test;
  74                                 croak "Overlapping segments" if $test < $segments{$pri};
  75                         }
  76                 }
  77         }
  78
  79         my @sections;
  80         my ($i, @seq) = (0, $self->seq);
  81         do {
  82                 my ($start, $end) = @segments[$i, $i + 1];
  83
  84                 # Create a new sequence object in the correct package, and put the
  85                 # segment into it
  86                 my $new_seq = $package->new(id => $self->id);
  87                 $new_seq->seq( @seq[ $start .. $end ] );
  88                 push @sections, $new_seq;
  89                 $i += 2;
  90         } while ($i < @segments);
  91
  92         return @sections;
  93 }
  94
  95 1;
  96
  97 __END__
  98
  99 =head1 NAME
 100
 101 Sequence - Holds information about a sequence
 102
 103 =head1 EXAMPLE
 104
 105   my $seq = Sequence->new;
 106
 107   $seq->id("Big wobbly molecule");
 108   my @residues = split //, "ASEQENCE";
 109   $seq->seq(@residues);
 110
 111 =head1 INHERITANCE
 112
 113 Inherits from the Root class.
 114
 115 =head1 METHODS
 116
 117 =head2 id()
 118
 119 Accessor for the sequence ID.
 120
 121 =head2 seq(@sequence_data)
 122
 123 Accessor for the sequence. Pass the information in as an array, one piece per position.
 124
 125 Returns an array reference if called in a scalar context, otherwise an array of the information.
 126
 127 =head2 length()
 128
 129 Returns the length of the sequence.
 130
 131 =head1 AUTHOR
 132
 133 Jonathan Barber <jon@compbio.dundee.ac.uk>
 134
 135 =cut