← Back to branch summary

~ubuntu-branches/ubuntu/trusty/bioperl/trusty

« back to all changes in this revision

Viewing changes to Bio/DB/CUTG.pm

  • Committer: Package Import Robot
  • Author(s): Charles Plessy
  • Date: 2013-09-22 13:39:48 UTC
  • mfrom: (3.1.11 sid)
  • Revision ID: package-import@ubuntu.com-20130922133948-c6z62zegjyp7ztou
Tags: 1.6.922-1
http://bugs.debian.org/722910
* New upstream release.
* Replaces and Breaks grinder (<< 0.5.3-3~) because of overlaping contents.
  Closes: #722910
* Stop Replacing and Breaking bioperl ( << 1.6.9 ): not needed anymore. 

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/DB/CUTG.pm
1
1
#
2
2
# BioPerl module for Bio::DB::CUTG
3
3
#
4
 
# Please direct questions and support issues to <bioperl-l@bioperl.org> 
 
4
# Please direct questions and support issues to <bioperl-l@bioperl.org>
5
5
#
6
6
# Cared for by Richard Adams (richard.adams@ed.ac.uk)
7
7
#
18
18
 
19
19
=head1 SYNOPSIS
20
20
 
21
 
       use Bio::CodonUsage::Table; 
 
21
       use Bio::CodonUsage::Table;
22
22
       use Bio::DB::CUTG;
23
23
 
24
24
       my $db = Bio::DB::CUTG->new(-sp =>'Pan troglodytes');
46
46
I intend at a later date to allow retrieval of multiple codon tables
47
47
e.g., from a wildcard search.
48
48
 
 
49
Examples URLs:
 
50
 
 
51
L<http://www.kazusa.or.jp/codon/cgi-bin/spsearch.cgi?species=Pan+troglodytes&c=s>
 
52
L<http://www.kazusa.or.jp/codon/cgi-bin/showcodon.cgi?species=37011&aa=1&style=GCG>
 
53
 
49
54
=head1 SEE ALSO
50
55
 
51
 
L<Bio::Tools::CodonTable>, 
52
 
L<Bio::WebAgent>, 
53
 
L<Bio::CodonUsage::Table>, 
 
56
L<Bio::Tools::CodonTable>,
 
57
L<Bio::WebAgent>,
 
58
L<Bio::CodonUsage::Table>,
54
59
L<Bio::CodonUsage::IO>
55
60
 
56
61
=head1 FEEDBACK
57
62
 
58
63
=head2 Mailing Lists
59
64
 
60
 
 
61
65
User feedback is an integral part of the evolution of this and other
62
66
Bioperl modules. Send your comments and suggestions preferably to one
63
67
of the Bioperl mailing lists.  Your participation is much appreciated.
65
69
  bioperl-l@bioperl.org                  - General discussion
66
70
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
67
71
 
68
 
=head2 Support 
 
72
=head2 Support
69
73
 
70
74
Please direct usage questions or support issues to the mailing list:
71
75
 
72
76
I<bioperl-l@bioperl.org>
73
77
 
74
 
rather than to the module maintainer directly. Many experienced and 
75
 
reponsive experts will be able look at the problem and quickly 
76
 
address it. Please include a thorough description of the problem 
 
78
rather than to the module maintainer directly. Many experienced and
 
79
reponsive experts will be able look at the problem and quickly
 
80
address it. Please include a thorough description of the problem
77
81
with code and data examples if at all possible.
78
82
 
79
83
=head2 Reporting Bugs
94
98
 
95
99
=cut
96
100
 
97
 
 
98
101
# Let the code begin...
99
102
 
100
 
 
101
 
 
102
103
package Bio::DB::CUTG;
103
104
use Bio::CodonUsage::IO;
104
105
use IO::String;
107
108
 
108
109
use base qw(Bio::WebAgent);
109
110
 
110
 
$QUERY_KEYS = { 
111
 
                                sp => 'full Latin species name',        
112
 
                                gc => 'genetic code id'
113
 
                         };
 
111
$QUERY_KEYS = {
 
112
    sp => 'full Latin species name',
 
113
    gc => 'genetic code id'
 
114
};
114
115
 
115
116
BEGIN {
116
 
                 $URL = "http://www.kazusa.or.jp"
117
 
        }
118
 
 
 
117
    $URL = "http://www.kazusa.or.jp";
 
118
}
119
119
 
120
120
=head2 new
121
121
 
122
122
 Title   : new
123
123
 Usage   : my $db = Bio::DB::CUTG->new()
124
 
 Returns : a reference to a new Bio::DB::CUTG 
 
124
 Returns : a reference to a new Bio::DB::CUTG
125
125
 Args    : hash of optional values for db query
126
126
 
127
127
=cut
128
128
 
129
129
sub new {
130
 
        my ($class, @args ) =@_;
131
 
        _check_args(@args);
132
 
        my $self = $class->SUPER::new(@args);
133
 
        return $self;
 
130
    my ( $class, @args ) = @_;
 
131
    _check_args(@args);
 
132
    my $self = $class->SUPER::new(@args);
 
133
    return $self;
134
134
}
135
135
 
136
136
=head2 query_keys
144
144
=cut
145
145
 
146
146
sub query_keys {
147
 
        return $QUERY_KEYS;
148
 
        }
 
147
    return $QUERY_KEYS;
 
148
}
149
149
 
150
150
=head2  sp
151
151
 
158
158
=cut
159
159
 
160
160
sub sp {
161
 
        my $self = shift;
162
 
        if (@_) {
163
 
                my $name = shift;
164
 
                        $self->{'_sp'} = $name;
165
 
                }
166
 
        return $self->{'_sp'}|| "Homo sapiens";
167
 
        
 
161
    my $self = shift;
 
162
    if (@_) {
 
163
        my $name = shift;
 
164
        $self->{'_sp'} = $name;
 
165
    }
 
166
    return $self->{'_sp'} || "Homo sapiens";
 
167
 
168
168
}
169
169
 
170
170
=head2  gc
178
178
=cut
179
179
 
180
180
sub gc {
181
 
        #### genetic code id for translations ####
182
 
        my $self = shift;
183
 
        if (@_) {
184
 
                if($_[0] =~ /^\d+$/ && $_[0] >= 1 && $_[0] <=15 && $_[0] != 7 
185
 
                                && $_[0] != 8) {
186
 
                        $self->{'_gc'} = shift;
187
 
                        }
188
 
                else {
189
 
                        $self->warn("invalid genetic code index - setting to standard default (1)");
190
 
                        $self->{'_gc'} = 1;
191
 
                        }
192
 
                }
193
 
        return $self->{'_gc'} || 1; #return 1 if not defined
194
 
 
195
 
        }
196
 
 
 
181
    #### genetic code id for translations ####
 
182
    my $self = shift;
 
183
    if (@_) {
 
184
        if (   $_[0] =~ /^\d+$/
 
185
            && $_[0] >= 1
 
186
            && $_[0] <= 15
 
187
            && $_[0] != 7
 
188
            && $_[0] != 8 )
 
189
        {
 
190
            $self->{'_gc'} = shift;
 
191
        }
 
192
        else {
 
193
            $self->warn(
 
194
                "invalid genetic code index - setting to standard default (1)");
 
195
            $self->{'_gc'} = 1;
 
196
        }
 
197
    }
 
198
    return $self->{'_gc'} || 1;    #return 1 if not defined
 
199
 
 
200
}
197
201
 
198
202
=head2  get_request
199
203
 
200
204
 Title  : get_request
201
205
 Usage  : my $cut = $db->get_request();
202
206
 Purpose: To query remote CUT with a species name
203
 
 Returns: a new codon usage table object 
 
207
 Returns: a new codon usage table object
204
208
 Args   : species  name(mandatory), genetic code id(optional)
205
209
 
206
210
=cut
207
211
 
208
212
sub get_request {
209
 
        my ($self, @args) = @_;
210
 
        _check_args(@args);
211
 
        shift;
212
 
        ### can put in parameters here as well
213
 
        while( @_ ) {
214
 
        my $key = shift;
 
213
    my ( $self, @args ) = @_;
 
214
    _check_args(@args);
 
215
    shift;
 
216
    ### can put in parameters here as well
 
217
    while (@_) {
 
218
        my $key = shift;
215
219
        $key =~ s/^-//;
216
220
        $self->$key(shift);
217
 
    }   
218
 
        $self->url($URL);
219
 
 
220
 
        ###1st of all search DB to check species exists and is unique
221
 
        my $nameparts =  join "+", $self->sp =~ /(\S+)/g;
222
 
        my $search_url = $self->url . "/codon/cgi-bin/spsearch.cgi?species=" 
223
 
                                        . $nameparts . "&c=s";
224
 
        my $rq = HTTP::Request->new(GET=>$search_url);
225
 
        my $reply = $self->request($rq);
226
 
    if ($reply->is_error) {
227
 
        $self->throw($reply->as_string()."\nError getting for url $search_url!\n");
228
 
    }
229
 
        my $content = $reply->content;
230
 
        return 0 unless $content;
231
 
    $self->debug (" reply from query is \n  $content");
232
 
        #####  if no matches, assign defaults - or can throw here?  ######
233
 
        if ($content =~ /not found/i) {
234
 
                $self->warn("organism not found -selecting human [9606] as default");
235
 
                $self->sp("9606");
236
 
                $self->_db("gbpri");
237
 
        }
238
 
 
239
 
        else {
240
 
                my @names = $content =~ /species=([^"]+)/g;
241
 
                ### get 1st species data from report ####
 
221
    }
 
222
    $self->url($URL);
 
223
 
 
224
    ###1st of all search DB to check species exists and is unique
 
225
    my $nameparts = join "+", $self->sp =~ /(\S+)/g;
 
226
    my $search_url =
 
227
      $self->url . "/codon/cgi-bin/spsearch.cgi?species=" . $nameparts . "&c=s";
 
228
    my $rq = HTTP::Request->new( GET => $search_url );
 
229
    my $reply = $self->request($rq);
 
230
    if ( $reply->is_error ) {
 
231
        $self->throw(
 
232
            $reply->as_string() . "\nError getting for url $search_url!\n" );
 
233
    }
 
234
    my $content = $reply->content;
 
235
    return 0 unless $content;
 
236
    $self->debug(" reply from query is \n  $content");
 
237
    #####  if no matches, assign defaults - or can throw here?  ######
 
238
    if ( $content =~ /not found/i ) {
 
239
        $self->warn("organism not found -selecting human [9606] as default");
 
240
        $self->sp("9606");
 
241
        $self->_db("gbpri");
 
242
    }
 
243
 
 
244
    else {
 
245
        my @names = $content =~ /species=([^"]+)/g;
 
246
        ### get 1st species data from report ####
242
247
        my @dbs = $content =~ /\[([^\]]+)\]:\s+\d+/g;
243
 
                ## warn if  more than 1 matching species ##
244
 
                ## if multiple species retrieved, choose first one by default ##
 
248
        ## warn if  more than 1 matching species ##
 
249
        ## if multiple species retrieved, choose first one by default ##
245
250
        $self->throw("No names returned for $nameparts") unless @names;
246
 
                if (@names >1 ){
247
 
                        $self->warn ("too many species - not a unique species id\n".
248
 
                         "selecting $names[0] using database [$dbs[0]]");
249
 
                }
250
 
                ### now assign species and database value
251
 
                $self->sp($names[0]);
252
 
                $self->_db($dbs[0]);
253
 
                }
254
 
 
255
 
 
256
 
        ######## now get codon table , all defaults established now
257
 
 
258
 
        ##construct URL##
259
 
        $nameparts = $self->sp;
260
 
 
261
 
        my $CT_url = $self->url . "/codon/cgi-bin/showcodon.cgi?species="
262
 
                                . $nameparts . "&aa=" . $self->gc . "&style=GCG";
 
251
        if ( @names > 1 ) {
 
252
            $self->warn( "too many species - not a unique species id\n"
 
253
                  . "selecting $names[0] using database [$dbs[0]]" );
 
254
        }
 
255
        ### now assign species and database value
 
256
        $self->sp( $names[0] );
 
257
        $self->_db( $dbs[0] );
 
258
    }
 
259
 
 
260
    ######## now get codon table , all defaults established now
 
261
 
 
262
    ##construct URL##
 
263
    $nameparts = $self->sp;
 
264
 
 
265
    my $CT_url =
 
266
        $self->url
 
267
      . "/codon/cgi-bin/showcodon.cgi?species="
 
268
      . $nameparts . "&aa="
 
269
      . $self->gc
 
270
      . "&style=GCG";
263
271
    $self->debug("URL : $CT_url\n");
264
 
        ## retrieve data in html##
265
 
        my $rq2 = HTTP::Request->new(GET => $CT_url);
 
272
    ## retrieve data in html##
 
273
    my $rq2 = HTTP::Request->new( GET => $CT_url );
266
274
    $reply = $self->request($rq2);
267
 
    if ($reply->is_error) {
268
 
        $self->throw($reply->as_string()."\nError getting for url $CT_url!\n");
 
275
    if ( $reply->is_error ) {
 
276
        $self->throw(
 
277
            $reply->as_string() . "\nError getting for url $CT_url!\n" );
269
278
    }
270
 
        my $content2 = $reply->content;
271
 
 
272
 
        ## strip html tags, basic but works here
273
 
        $content2 =~ s/<[^>]+>//sg;
274
 
        $content2 =~ s/Format.*//sg;
275
 
    $self->debug ("raw DDB table is :\n $content2");
276
 
 
277
 
        ### and pass to Bio::CodonUsage::IO for parsing
278
 
        my $iostr = IO::String->new($content2);
279
 
        my $io = Bio::CodonUsage::IO->new (-fh=>$iostr);
280
 
 
281
 
        ##return object ##
282
 
        return $io->next_data;
 
279
    my $content2 = $reply->content;
 
280
 
 
281
    ## strip html tags, basic but works here
 
282
    $content2 =~ s/<[^>]+>//sg;
 
283
    $content2 =~ s/Format.*//sg;
 
284
    $self->debug("raw DDB table is :\n $content2");
 
285
 
 
286
    ### and pass to Bio::CodonUsage::IO for parsing
 
287
    my $iostr = IO::String->new($content2);
 
288
    my $io = Bio::CodonUsage::IO->new( -fh => $iostr );
 
289
 
 
290
    ##return object ##
 
291
    return $io->next_data;
283
292
}
284
293
 
285
294
sub _check_args {
286
295
 
287
 
        ###checks parameters for matching $QUERYKEYS
288
 
        my @args = @_;
289
 
        while (my $key = shift @args) {
 
296
    ###checks parameters for matching $QUERYKEYS
 
297
    my @args = @_;
 
298
    while ( my $key = shift @args ) {
290
299
        $key = lc($key);
291
 
                $key =~ s/\-//;
292
 
                
293
 
                if (!exists ($QUERY_KEYS->{$key})) {
294
 
                        Bio::Root::Root->throw("invalid parameter - must be one of [" .
295
 
                                                (join "] [", keys %$QUERY_KEYS) . "]");
296
 
                }
297
 
                shift @args;
298
 
        }
 
300
        $key =~ s/\-//;
 
301
 
 
302
        if ( !exists( $QUERY_KEYS->{$key} ) ) {
 
303
            Bio::Root::Root->throw( "invalid parameter - must be one of ["
 
304
                  . ( join "] [", keys %$QUERY_KEYS )
 
305
                  . "]" );
 
306
        }
 
307
        shift @args;
 
308
    }
299
309
}
300
310
 
301
311
#### internal URL parameter not specifiable ######
302
312
sub _db {
303
 
        my $self = shift;
304
 
        if (@_) {
305
 
                $self->{'_db'} = shift;
306
 
                }
307
 
        return $self->{'_db'};
 
313
    my $self = shift;
 
314
    if (@_) {
 
315
        $self->{'_db'} = shift;
 
316
    }
 
317
    return $self->{'_db'};
308
318
}
309
319
 
310
320
1;