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 =head1 SEE ALSO
  50
  51 L<Bio::Tools::CodonTable>,
  52 L<Bio::WebAgent>,
  53 L<Bio::CodonUsage::Table>,
  54 L<Bio::CodonUsage::IO>
  55
  56 =head1 FEEDBACK
  57
  58 =head2 Mailing Lists
  59
  60
  61 User feedback is an integral part of the evolution of this and other
  62 Bioperl modules. Send your comments and suggestions preferably to one
  63 of the Bioperl mailing lists.  Your participation is much appreciated.
  64
  65   bioperl-l@bioperl.org                  - General discussion
  66   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  67
  68 =head2 Support
  69
  70 Please direct usage questions or support issues to the mailing list:
  71
  72 I<bioperl-l@bioperl.org>
  73
  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
  77 with code and data examples if at all possible.
  78
  79 =head2 Reporting Bugs
  80
  81 Report bugs to the Bioperl bug tracking system to help us keep track
  82 the bugs and their resolution.  Bug reports can be submitted via the web:
  83
  84   http://bugzilla.open-bio.org/
  85
  86 =head1 AUTHORS
  87
  88 Richard Adams, Richard.Adams@ed.ac.uk
  89
  90 =head1 APPENDIX
  91
  92 The rest of the documentation details each of the object
  93 methods. Internal methods are usually preceded with a _
  94
  95 =cut
  96
  97
  98 # Let the code begin...
  99
 100
 101
 102 package Bio::DB::CUTG;
 103 use Bio::CodonUsage::IO;
 104 use IO::String;
 105 use URI::Escape;
 106 use vars qw($URL $QUERY_KEYS);
 107
 108 use base qw(Bio::WebAgent);
 109
 110 $QUERY_KEYS = {
 111                                 sp => 'full Latin species name',
 112                                 gc => 'genetic code id'
 113                          };
 114
 115 BEGIN {
 116                  $URL = "http://www.kazusa.or.jp"
 117         }
 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+$/ && $_[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
 197
 198 =head2  get_request
 199
 200  Title  : get_request
 201  Usage  : my $cut = $db->get_request();
 202  Purpose: To query remote CUT with a species name
 203  Returns: a new codon usage table object
 204  Args   : species  name(mandatory), genetic code id(optional)
 205
 206 =cut
 207
 208 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;
 215         $key =~ s/^-//;
 216         $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 ####
 242         my @dbs = $content =~ /\[([^\]]+)\]:\s+\d+/g;
 243                 ## warn if  more than 1 matching species ##
 244                 ## if multiple species retrieved, choose first one by default ##
 245         $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";
 263     $self->debug("URL : $CT_url\n");
 264         ## retrieve data in html##
 265         my $rq2 = HTTP::Request->new(GET => $CT_url);
 266     $reply = $self->request($rq2);
 267     if ($reply->is_error) {
 268         $self->throw($reply->as_string()."\nError getting for url $CT_url!\n");
 269     }
 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;
 283 }
 284
 285 sub _check_args {
 286
 287         ###checks parameters for matching $QUERYKEYS
 288         my @args = @_;
 289         while (my $key = shift @args) {
 290         $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         }
 299 }
 300
 301 #### internal URL parameter not specifiable ######
 302 sub _db {
 303         my $self = shift;
 304         if (@_) {
 305                 $self->{'_db'} = shift;
 306                 }
 307         return $self->{'_db'};
 308 }
 309
 310 1;