Bio/Tools/SiRNA/Ruleset/tuschl.pm

   1 #
   2 #
   3 # BioPerl module for Bio::Tools::SiRNA::Ruleset::tuschl
   4 #
   5 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   6 #
   7 # Cared for by Donald Jackson, donald.jackson@bms.com
   8 #
   9 # Copyright Bristol-Myers Squibb
  10 #
  11 # You may distribute this module under the same terms as perl itself
  12
  13 # POD documentation - main docs before the code
  14
  15 =head1 NAME
  16
  17 Bio::Tools::SiRNA::Ruleset::tuschl - Perl object implementing the
  18 tuschl group's rules for designing small inhibitory RNAs
  19
  20 =head1 SYNOPSIS
  21
  22 Do not use this module directly.  Instead, use Bio::Tools::SiRNA and
  23 specify the tuschl ruleset:
  24
  25   use Bio::Tools::SiRNA;
  26
  27   my $sirna_designer = Bio::Tools::SiRNA->new( -target => $bio_seq,
  28                                                -rules  => 'tuschl'
  29     );
  30   my @pairs = $sirna_designer->design;
  31
  32   foreach $pair (@pairs) {
  33       my $sense_oligo_sequence = $pair->sense->seq;
  34       my $antisense_oligo_sequence = $pair->antisense->seq;
  35
  36       # print out results
  37       print join ("\t", $pair->start, $pair->end, $pair->rank,
  38                   $sense_oligo_sequence, $antisense_oligo_sequence), "\n";
  39   }
  40
  41 =head1 DESCRIPTION
  42
  43 This package implements the rules for designing siRNA reagents
  44 developed by Tuschl and colleagues (see
  45 http://www.rockefeller.edu/labheads/tuschl/sirna.html). It looks for
  46 oligos that match the following patterns in the target sequence:
  47
  48   1. AA(N19)TT (rank 1)
  49   2. AA(N21) (rank 2)
  50   3. NA(N21) (rank 3)
  51
  52 The package also supports selection of siRNA seqences that can be
  53 transcribed by pol3:
  54
  55     A[A,G]N17[C,T]
  56
  57 =head1 SEE ALSO
  58
  59 L<Bio::Tools::SiRNA>, L<Bio::SeqFeature::SiRNA::Pair>,
  60 L<Bio::SeqFeature::SiRNA::Oligo>.
  61
  62 =head1 FEEDBACK
  63
  64 =head2 Mailing Lists
  65
  66 User feedback is an integral part of the evolution of this and other
  67 Bioperl modules. Send your comments and suggestions preferably to
  68 the Bioperl mailing list.  Your participation is much appreciated.
  69
  70   bioperl-l@bioperl.org                  - General discussion
  71   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  72
  73 =head2 Support
  74
  75 Please direct usage questions or support issues to the mailing list:
  76
  77 I<bioperl-l@bioperl.org>
  78
  79 rather than to the module maintainer directly. Many experienced and
  80 reponsive experts will be able look at the problem and quickly
  81 address it. Please include a thorough description of the problem
  82 with code and data examples if at all possible.
  83
  84 =head2 Reporting Bugs
  85
  86 Report bugs to the Bioperl bug tracking system to help us keep track
  87 of the bugs and their resolution. Bug reports can be submitted via
  88 the web:
  89
  90   https://github.com/bioperl/bioperl-live/issues
  91
  92 =head1 AUTHOR
  93
  94 Donald Jackson (donald.jackson@bms.com)
  95
  96 =head1 APPENDIX
  97
  98 The rest of the documentation details each of the object methods.
  99 Internal methods are usually preceded with a _
 100
 101
 102 =cut
 103
 104 package Bio::Tools::SiRNA::Ruleset::tuschl;
 105
 106 use strict;
 107 use warnings;
 108
 109 use base qw(Bio::Tools::SiRNA);
 110
 111 our %PATTERNS = ( 1     => '(AA.{19}TT)',
 112                   2     => '(AA.{19}[ACG][ACG])',
 113                   3     => '([CGT]A.{21})',
 114                   Pol3  => '(.A[AG].{17}[CT]..)'
 115                   );
 116
 117 our $DEFAULT_CUTOFF = 2;
 118
 119 =head2 new
 120
 121   Title : new
 122   Usage : Do not call directly - use Bio::Tools::SiRNA->new instead.
 123   Returns : Bio::Tools::SiRNA::Ruleset::saigo object
 124   Args  : none
 125
 126 =cut
 127
 128 sub new {
 129     my ($proto, %args) = @_;
 130     my $class = ref($proto) || $proto;
 131
 132     $args{'RULES'} = 'tuschl';
 133
 134     return $class->SUPER::new(%args);
 135 }
 136
 137 sub _regex {
 138     my ($self, $rank) = @_;
 139     return $PATTERNS{$rank};
 140 }
 141
 142 sub cutoff {
 143     my ($self, $cutoff) = @_;
 144     if ($cutoff) {
 145         $self->{'cutoff'} = $cutoff;
 146     }
 147     elsif (!$self->{'cutoff'}) {
 148         $self->{'cutoff'} = $DEFAULT_CUTOFF;
 149     }
 150     return $self->{'cutoff'};
 151 }
 152
 153
 154 sub _get_oligos {
 155     #use regular expressions to pull out oligos
 156     my ($self) = @_;
 157
 158     my @ranks;
 159     if ($self->cutoff eq 'pol3') {
 160         @ranks = ('pol3');
 161     }
 162     else {
 163         @ranks = (1 .. $self->cutoff);
 164     }
 165
 166     foreach my $rank (@ranks) {
 167         my $regex = $self->_regex($rank);
 168         #my @exclude;
 169
 170
 171 #       my ($targregion) = grep { $_->primary_tag eq 'Target' } $self->target->top_SeqFeatures;
 172 #       my $seq = $targregion->seq->seq;
 173 #       # but this way I loose start info
 174 #       my $targstart = $targregion->start;
 175         my ($seq, $targstart) = $self->_get_targetregion();
 176
 177         while ( $seq =~ /(.*?)$regex/gi ) {
 178             my $target = $2;
 179
 180             # check for too many Gs (or Cs on the other strand)
 181             my $max_g = $self->gstring;
 182             next if ( $target =~ /G{$max_g,}/io );
 183             next if ( $target =~ /C{$max_g,}/io );
 184 #       skip Ns (for filtering)
 185             next if ( $target =~ /N/i);
 186
 187             my $start = length($1) + $targstart;
 188             my $stop = $start + length($target) -1;
 189
 190             my @gc = ( $target =~ /G|C/gi);
 191             my $fxGC = sprintf("%2.2f", (scalar(@gc) / length($target)));
 192             next if ($fxGC < $self->min_gc);
 193             next if ($fxGC > $self->max_gc);
 194
 195             $self->add_oligos($target, $start, $rank);
 196         }
 197     }
 198 }
 199
 200
 201 sub _get_sense {
 202     my ($self, $target) = @_;
 203     # trim off 1st 2 nt to get overhang
 204     $target =~ s/^..//;
 205     # convert T's to U's (transcribe)
 206     $target =~ s/T/U/gi;
 207     # force last 2 nt to be T's
 208     $target =~ s/..$/TT/;
 209
 210     return $target;
 211 }
 212
 213 sub _get_anti {
 214     my ($self, $target) = @_;
 215     my @target = split(//, $target);
 216     my ($nt,@antitarget);
 217
 218     while ($nt = pop @target) {
 219         push(@antitarget, $self->_comp($nt));
 220     }
 221     my $anti = join('', @antitarget);
 222     # trim off 1st 2 nt to get overhang
 223     $anti =~ s/^..//;
 224     # convert T's to U's
 225     $anti =~ s/T/U/gi;
 226     # convert last 2 NT's to T
 227     $anti =~ s/..$/TT/;
 228
 229     return $anti;
 230 }
 231
 232
 233 1;