File Coverage

Bio/Tools/SiRNA/Ruleset/tuschl.pm
Criterion Covered Total %
statement 49 56 87.5
branch 12 16 75.0
condition 0 3 0.0
subroutine 8 9 88.8
pod 1 2 50.0
total 70 86 81.4


line stmt bran cond sub pod time code
1             #
2             #
3             # BioPerl module for Bio::Tools::SiRNA::Ruleset::tuschl
4             #
5             # Please direct questions and support issues to
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, L,
60             L.
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
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 1     1   4 use strict;
  1         1  
  1         28  
107 1     1   3 use warnings;
  1         1  
  1         32  
108              
109 1     1   4 use base qw(Bio::Tools::SiRNA);
  1         1  
  1         640  
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 0     0 1 0 my ($proto, %args) = @_;
130 0   0     0 my $class = ref($proto) || $proto;
131            
132 0         0 $args{'RULES'} = 'tuschl';
133              
134 0         0 return $class->SUPER::new(%args);
135             }
136              
137             sub _regex {
138 9     9   14 my ($self, $rank) = @_;
139 9         19 return $PATTERNS{$rank};
140             }
141              
142             sub cutoff {
143 6     6 0 6 my ($self, $cutoff) = @_;
144 6 50       19 if ($cutoff) {
    50          
145 0         0 $self->{'cutoff'} = $cutoff;
146             }
147             elsif (!$self->{'cutoff'}) {
148 0         0 $self->{'cutoff'} = $DEFAULT_CUTOFF;
149             }
150 6         14 return $self->{'cutoff'};
151             }
152              
153              
154             sub _get_oligos {
155             #use regular expressions to pull out oligos
156 3     3   4 my ($self) = @_;
157              
158 3         4 my @ranks;
159 3 50       9 if ($self->cutoff eq 'pol3') {
160 0         0 @ranks = ('pol3');
161             }
162             else {
163 3         8 @ranks = (1 .. $self->cutoff);
164             }
165            
166 3         9 foreach my $rank (@ranks) {
167 9         22 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 9         25 my ($seq, $targstart) = $self->_get_targetregion();
176              
177 9         303 while ( $seq =~ /(.*?)$regex/gi ) {
178 679         1124 my $target = $2;
179              
180             # check for too many Gs (or Cs on the other strand)
181 679         2090 my $max_g = $self->gstring;
182 679 100       2015 next if ( $target =~ /G{$max_g,}/io );
183 623 100       1494 next if ( $target =~ /C{$max_g,}/io );
184             # skip Ns (for filtering)
185 571 50       746 next if ( $target =~ /N/i);
186              
187 571         790 my $start = length($1) + $targstart;
188 571         541 my $stop = $start + length($target) -1;
189              
190 571         5757 my @gc = ( $target =~ /G|C/gi);
191 571         3174 my $fxGC = sprintf("%2.2f", (scalar(@gc) / length($target)));
192 571 100       1888 next if ($fxGC < $self->min_gc);
193 470 100       1183 next if ($fxGC > $self->max_gc);
194            
195 312         521 $self->add_oligos($target, $start, $rank);
196             }
197             }
198             }
199              
200            
201             sub _get_sense {
202 312     312   245 my ($self, $target) = @_;
203             # trim off 1st 2 nt to get overhang
204 312         583 $target =~ s/^..//;
205             # convert T's to U's (transcribe)
206 312         957 $target =~ s/T/U/gi;
207             # force last 2 nt to be T's
208 312         581 $target =~ s/..$/TT/;
209              
210 312         423 return $target;
211             }
212              
213             sub _get_anti {
214 312     312   251 my ($self, $target) = @_;
215 312         1092 my @target = split(//, $target);
216 312         210 my ($nt,@antitarget);
217              
218 312         566 while ($nt = pop @target) {
219 7176         7742 push(@antitarget, $self->_comp($nt));
220             }
221 312         670 my $anti = join('', @antitarget);
222             # trim off 1st 2 nt to get overhang
223 312         889 $anti =~ s/^..//;
224             # convert T's to U's
225 312         1116 $anti =~ s/T/U/gi;
226             # convert last 2 NT's to T
227 312         547 $anti =~ s/..$/TT/;
228              
229 312         661 return $anti;
230             }
231              
232              
233             1;