view release on metacpan or  search on metacpan

Bio/DB/CUTG.pm  view on Meta::CPAN

}

=head2  gc

 Title  : gc
 Usage  : my $gc = $db->gc();
 Purpose: Get/set method for genetic code id
 Returns: void or genetic code  integer
 Args   : None or genetic code integer

=cut

sub gc {
    #### genetic code id for translations ####
    my $self = shift;
    if (@_) {
        if (   $_[0] =~ /^\d+$/
            && $_[0] >= 1
            && $_[0] <= 15
            && $_[0] != 7
            && $_[0] != 8 )
        {
            $self->{'_gc'} = shift;
        }
        else {
            $self->warn(
                "invalid genetic code index - setting to standard default (1)");
            $self->{'_gc'} = 1;
        }
    }
    return $self->{'_gc'} || 1;    #return 1 if not defined

}

=head2  get_request

 Title  : get_request
 Usage  : my $cut = $db->get_request();
 Purpose: To query remote CUT with a species name
 Returns: a new codon usage table object
 Args   : species  name(mandatory), genetic code id(optional)

=cut

sub get_request {
    my ( $self, @args ) = @_;
    _check_args(@args);
    shift;
    ### can put in parameters here as well
    while (@_) {
        my $key = shift;
        $key =~ s/^-//;
        $self->$key(shift);
    }
    $self->url($URL);

    ###1st of all search DB to check species exists and is unique
    my $nameparts = join "+", $self->sp =~ /(\S+)/g;
    my $search_url =
      $self->url . "/codon/cgi-bin/spsearch.cgi?species=" . $nameparts . "&c=s";
    my $rq = HTTP::Request->new( GET => $search_url );
    my $reply = $self->request($rq);
    if ( $reply->is_error ) {
        $self->throw(
            $reply->as_string() . "\nError getting for url $search_url!\n" );
    }
    my $content = $reply->content;
    return 0 unless $content;
    $self->debug(" reply from query is \n  $content");
    #####  if no matches, assign defaults - or can throw here?  ######
    if ( $content =~ /not found/i ) {
        $self->warn("organism not found -selecting human [9606] as default");
        $self->sp("9606");
        $self->_db("gbpri");
    }

    else {
        my @names = $content =~ /species=([^"]+)/g;
        ### get 1st species data from report ####
        my @dbs = $content =~ /\[([^\]]+)\]:\s+\d+/g;
        ## warn if  more than 1 matching species ##
        ## if multiple species retrieved, choose first one by default ##
        $self->throw("No names returned for $nameparts") unless @names;
        if ( @names > 1 ) {
            $self->warn( "too many species - not a unique species id\n"
                  . "selecting $names[0] using database [$dbs[0]]" );
        }
        ### now assign species and database value
        $self->sp( $names[0] );
        $self->_db( $dbs[0] );
    }

    ######## now get codon table , all defaults established now

    ##construct URL##
    $nameparts = $self->sp;

    my $CT_url =
        $self->url
      . "/codon/cgi-bin/showcodon.cgi?species="
      . $nameparts . "&aa="
      . $self->gc
      . "&style=GCG";
    $self->debug("URL : $CT_url\n");
    ## retrieve data in html##
    my $rq2 = HTTP::Request->new( GET => $CT_url );
    $reply = $self->request($rq2);
    if ( $reply->is_error ) {
        $self->throw(
            $reply->as_string() . "\nError getting for url $CT_url!\n" );
    }
    my $content2 = $reply->content;

    ## strip html tags, basic but works here
    $content2 =~ s/<[^>]+>//sg;
    $content2 =~ s/Format.*//sg;
    $self->debug("raw DDB table is :\n $content2");

    ### and pass to Bio::CodonUsage::IO for parsing
    my $iostr = IO::String->new($content2);
    my $io = Bio::CodonUsage::IO->new( -fh => $iostr );

    ##return object ##
    return $io->next_data;
}

sub _check_args {

    ###checks parameters for matching $QUERYKEYS
    my @args = @_;
    while ( my $key = shift @args ) {
        $key = lc($key);
        $key =~ s/\-//;

        if ( !exists( $QUERY_KEYS->{$key} ) ) {
            Bio::Root::Root->throw( "invalid parameter - must be one of ["
                  . ( join "] [", keys %$QUERY_KEYS )
                  . "]" );
        }
        shift @args;
    }
}

#### internal URL parameter not specifiable ######
sub _db {
    my $self = shift;
    if (@_) {
        $self->{'_db'} = shift;
    }
    return $self->{'_db'};
}

1;