Bio/DB/CUTG.pm

   1 #
   2 # BioPerl module for Bio::DB::CUTG
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Richard Adams (richard.adams@ed.ac.uk)
   7 #
   8 # Copyright Richard Adams
   9 #
  10 # You may distribute this module under the same terms as perl itself
  11
  12 # POD documentation - main docs before the code
  13
  14 =head1 NAME
  15
  16 Bio::DB::CUTG - for access to the Codon usage Database
  17 at http://www.kazusa.or.jp/codon.
  18
  19 =head1 SYNOPSIS
  20
  21        use Bio::CodonUsage::Table;
  22        use Bio::DB::CUTG;
  23
  24        my $db = Bio::DB::CUTG->new(-sp =>'Pan troglodytes');
  25        my $CUT = $db->get_request();
  26
  27
  28 =head1 DESCRIPTION
  29
  30 This class retrieves and objectifies codon usage tables either from the
  31 CUTG web database . The idea is that you can initially retrieve a CUT from
  32 the web database, and write it to file in a way that can be read in
  33 later, using the Bio::CodonUsage::IO module.
  34
  35 For a web query, two parameters need to be specified: species(sp) and
  36 genetic code id (gc). The database is searched using regular
  37 expressions, therefore the full latin name must be given to specify
  38 the organism. If the species name is ambiguous the first CUT in the
  39 list is retrieved.  Defaults are Homo sapiens and 1(standard genetic
  40 code).  If you are retrieving CUTs from organisms using other genetic
  41 codes this needs to be put in as a parameter. Parameters can be
  42 entered in the constructor or in the get_web_request
  43 ()method. Allowable parameters are listed in the $QUERY_KEYS hash
  44 reference variable.
  45
  46 I intend at a later date to allow retrieval of multiple codon tables
  47 e.g., from a wildcard search.
  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
  54 =head1 SEE ALSO
  55
  56 L<Bio::Tools::CodonTable>,
  57 L<Bio::WebAgent>,
  58 L<Bio::CodonUsage::Table>,
  59 L<Bio::CodonUsage::IO>
  60
  61 =head1 FEEDBACK
  62
  63 =head2 Mailing Lists
  64
  65 User feedback is an integral part of the evolution of this and other
  66 Bioperl modules. Send your comments and suggestions preferably to one
  67 of the Bioperl mailing lists.  Your participation is much appreciated.
  68
  69   bioperl-l@bioperl.org                  - General discussion
  70   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  71
  72 =head2 Support
  73
  74 Please direct usage questions or support issues to the mailing list:
  75
  76 I<bioperl-l@bioperl.org>
  77
  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
  81 with code and data examples if at all possible.
  82
  83 =head2 Reporting Bugs
  84
  85 Report bugs to the Bioperl bug tracking system to help us keep track
  86 the bugs and their resolution.  Bug reports can be submitted via the web:
  87
  88   https://github.com/bioperl/bioperl-live/issues
  89
  90 =head1 AUTHORS
  91
  92 Richard Adams, Richard.Adams@ed.ac.uk
  93
  94 =head1 APPENDIX
  95
  96 The rest of the documentation details each of the object
  97 methods. Internal methods are usually preceded with a _
  98
  99 =cut
 100
 101 # Let the code begin...
 102
 103 package Bio::DB::CUTG;
 104 use Bio::CodonUsage::IO;
 105 use IO::String;
 106 use URI::Escape;
 107 use vars qw($URL $QUERY_KEYS);
 108
 109 use base qw(Bio::WebAgent);
 110
 111 $QUERY_KEYS = {
 112     sp => 'full Latin species name',
 113     gc => 'genetic code id'
 114 };
 115
 116 BEGIN {
 117     $URL = "http://www.kazusa.or.jp";
 118 }
 119
 120 =head2 new
 121
 122  Title   : new
 123  Usage   : my $db = Bio::DB::CUTG->new()
 124  Returns : a reference to a new Bio::DB::CUTG
 125  Args    : hash of optional values for db query
 126
 127 =cut
 128
 129 sub new {
 130     my ( $class, @args ) = @_;
 131     _check_args(@args);
 132     my $self = $class->SUPER::new(@args);
 133     return $self;
 134 }
 135
 136 =head2 query_keys
 137
 138  Title   : query_keys
 139  Usage   : $db->query_keys()
 140  Purpose : To determine valid keys for parameters for db query.
 141  Returns : a reference to a hash describing valid query keys
 142  Args    : none
 143
 144 =cut
 145
 146 sub query_keys {
 147     return $QUERY_KEYS;
 148 }
 149
 150 =head2  sp
 151
 152  Title  : sp
 153  Usage  : my $sp = $db->sp();
 154  Purpose: Get/set method for species name
 155  Returns: void or species name string
 156  Args   : None or species name string
 157
 158 =cut
 159
 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
 168 }
 169
 170 =head2  gc
 171
 172  Title  : gc
 173  Usage  : my $gc = $db->gc();
 174  Purpose: Get/set method for genetic code id
 175  Returns: void or genetic code  integer
 176  Args   : None or genetic code integer
 177
 178 =cut
 179
 180 sub gc {
 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 }
 201
 202 =head2  get_request
 203
 204  Title  : get_request
 205  Usage  : my $cut = $db->get_request();
 206  Purpose: To query remote CUT with a species name
 207  Returns: a new codon usage table object
 208  Args   : species  name(mandatory), genetic code id(optional)
 209
 210 =cut
 211
 212 sub get_request {
 213     my ( $self, @args ) = @_;
 214     _check_args(@args);
 215     shift;
 216     ### can put in parameters here as well
 217     while (@_) {
 218         my $key = shift;
 219         $key =~ s/^-//;
 220         $self->$key(shift);
 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 ####
 247         my @dbs = $content =~ /\[([^\]]+)\]:\s+\d+/g;
 248         ## warn if  more than 1 matching species ##
 249         ## if multiple species retrieved, choose first one by default ##
 250         $self->throw("No names returned for $nameparts") unless @names;
 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";
 271     $self->debug("URL : $CT_url\n");
 272     ## retrieve data in html##
 273     my $rq2 = HTTP::Request->new( GET => $CT_url );
 274     $reply = $self->request($rq2);
 275     if ( $reply->is_error ) {
 276         $self->throw(
 277             $reply->as_string() . "\nError getting for url $CT_url!\n" );
 278     }
 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;
 292 }
 293
 294 sub _check_args {
 295
 296     ###checks parameters for matching $QUERYKEYS
 297     my @args = @_;
 298     while ( my $key = shift @args ) {
 299         $key = lc($key);
 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     }
 309 }
 310
 311 #### internal URL parameter not specifiable ######
 312 sub _db {
 313     my $self = shift;
 314     if (@_) {
 315         $self->{'_db'} = shift;
 316     }
 317     return $self->{'_db'};
 318 }
 319
 320 1;