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