← Back to branch summary

~ubuntu-branches/ubuntu/raring/bioperl/raring

« back to all changes in this revision

Viewing changes to Bio/DB/Expression/geo.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2008-03-18 14:44:57 UTC
  • mfrom: (4 hardy)
  • mto: This revision was merged to the branch mainline in revision 6.
  • Revision ID: james.westby@ubuntu.com-20080318144457-1jjoztrvqwf0gruk
http://bugs.debian.org/448890
* debian/control:
  - Removed MIA Matt Hope (dopey) from the Uploaders field.
    Thank you for your work, Matt. I hope you are doing well.
  - Downgraded some recommended package to the 'Suggests' priority,
    according to the following discussion on Upstream's mail list.
    http://bioperl.org/pipermail/bioperl-l/2008-March/027379.html
    (Closes: #448890)
* debian/copyright converted to machine-readable format.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/DB/Expression/geo.pm
 
1
=head1 NAME
 
2
 
 
3
Bio::DB::Expression::geo - *** DESCRIPTION of Class
 
4
 
 
5
=head1 SYNOPSIS
 
6
 
 
7
*** Give standard usage here
 
8
 
 
9
=head1 DESCRIPTION
 
10
 
 
11
*** Describe the object here
 
12
 
 
13
=head1 FEEDBACK
 
14
 
 
15
=head2 Mailing Lists
 
16
 
 
17
User feedback is an integral part of the evolution of this and other
 
18
Bioperl modules. Send your comments and suggestions preferably to the
 
19
Bioperl mailing list.  Your participation is much appreciated.
 
20
 
 
21
  bioperl-l@bioperl.org                  - General discussion
 
22
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
 
23
 
 
24
=head2 Reporting Bugs
 
25
 
 
26
Report bugs to the Bioperl bug tracking system to help us keep track
 
27
of the bugs and their resolution. Bug reports can be submitted via the
 
28
web:
 
29
 
 
30
  http://bugzilla.open-bio.org/
 
31
 
 
32
=head1 AUTHOR
 
33
 
 
34
Allen Day E<lt>allenday@ucla.eduE<gt>
 
35
 
 
36
=head1 APPENDIX
 
37
 
 
38
The rest of the documentation details each of the object methods.
 
39
Internal methods are usually preceded with a '_'.  Methods are
 
40
in alphabetical order for the most part.
 
41
 
 
42
=cut
 
43
 
 
44
 
 
45
# Let the code begin...
 
46
 
 
47
package Bio::DB::Expression::geo;
 
48
use strict;
 
49
use base qw(Bio::DB::Expression);
 
50
 
 
51
use Bio::Expression::Contact;
 
52
use Bio::Expression::DataSet;
 
53
use Bio::Expression::Platform;
 
54
use Bio::Expression::Sample;
 
55
 
 
56
use constant URL_PLATFORMS => 'http://www.ncbi.nlm.nih.gov/geo/query/browse.cgi?pgsize=100000&mode=platforms&submitter=-1&filteron=0&filtervalue=-1&private=1&sorton=pub_date&sortdir=1&start=1';
 
57
use constant URL_PLATFORM => 'http://www.ncbi.nlm.nih.gov/projects/geo/query/acc.cgi?form=text&view=full&acc=';
 
58
use constant URL_DATASET => 'http://www.ncbi.nlm.nih.gov/projects/geo/query/acc.cgi?form=text&view=full&acc=';
 
59
use constant URL_SAMPLE => 'http://www.ncbi.nlm.nih.gov/projects/geo/query/acc.cgi?form=text&view=full&acc=';
 
60
 
 
61
=head2 _initialize()
 
62
 
 
63
 Usage   : $obj->_initialize(%arg);
 
64
 Function: Internal method to initialize a new Bio::DB::Expression::geo object
 
65
 Returns : true on success
 
66
 Args    : Arguments passed to new()
 
67
 
 
68
=cut
 
69
 
 
70
sub _initialize {
 
71
  my($self,%arg) = @_;
 
72
 
 
73
  foreach my $arg (keys %arg){
 
74
    my $marg = $arg;
 
75
    $marg =~ s/^-//;
 
76
    $self->$marg($arg{$arg}) if $self->can($marg);
 
77
  }
 
78
 
 
79
  return 1;
 
80
}
 
81
 
 
82
=head2 get_platforms()
 
83
 
 
84
 Usage   :
 
85
 Function:
 
86
 Example :
 
87
 Returns : a list of Bio::Expression::Platform objects
 
88
 Args    :
 
89
 
 
90
=cut
 
91
 
 
92
sub get_platforms {
 
93
  my ($self,@args) = @_;
 
94
 
 
95
  my $doc = $self->_get_url( URL_PLATFORMS );
 
96
  $doc =~ s!^.+?>Release date<.+?</tr>(.+)</table>!$1!gs;
 
97
 
 
98
  my @platforms = ();
 
99
  my @records = split m!</tr>\s+<tr>!, $doc;
 
100
 
 
101
  foreach my $record ( @records ) {
 
102
    my ($platform_acc,$name,$tax_acc,$contact_acc,$contact_name) =
 
103
      $record =~ m!acc\.cgi\?acc=(.+?)".+?<td.+?>(.+?)<.+?<td.+?>.+?<.+?<td.+?>.+?href=".+?id=(.+?)".+?<td.+?OpenSubmitter\((\d+?)\).+?>(.+?)<!s;
 
104
    next unless $platform_acc;
 
105
 
 
106
    my $platform = Bio::Expression::Platform->new(
 
107
                                                  -accession => $platform_acc,
 
108
                                                  -name => $name,
 
109
                                                  -_taxon_id => $tax_acc,
 
110
                                                  -contact => Bio::Expression::Contact->new(
 
111
                                                                                            -source => 'geo',
 
112
                                                                                            -accession => $contact_acc,
 
113
                                                                                            -name => $contact_name,
 
114
                                                                                            -db => $self
 
115
                                                                                           ),
 
116
                                                  -db => $self,
 
117
                                                 );
 
118
    push @platforms, $platform;
 
119
  }
 
120
 
 
121
  return @platforms;
 
122
}
 
123
 
 
124
=head2 get_samples()
 
125
 
 
126
 Usage   :
 
127
 Function:
 
128
 Example :
 
129
 Returns : a list of Bio::Expression::Sample objects
 
130
 Args    :
 
131
 
 
132
=cut
 
133
 
 
134
sub get_samples {
 
135
  my ($self,@args) = @_;
 
136
  $self->throw_not_implemented();
 
137
}
 
138
 
 
139
=head2 get_contacts()
 
140
 
 
141
 Usage   :
 
142
 Function:
 
143
 Example :
 
144
 Returns : a list of Bio::Expression::Contact objects
 
145
 Args    :
 
146
 
 
147
=cut
 
148
 
 
149
sub get_contacts {
 
150
  my ($self,@args) = @_;
 
151
  $self->throw_not_implemented();
 
152
}
 
153
 
 
154
=head2 get_datasets()
 
155
 
 
156
 Usage   : $db->get_datasets('accession');
 
157
 Function:
 
158
 Example :
 
159
 Returns : a list of Bio::Expression::DataSet objects
 
160
 Args    :
 
161
 
 
162
=cut
 
163
 
 
164
sub get_datasets {
 
165
  my ($self,$platform) = @_;
 
166
 
 
167
  my @lines = split /\n/, $self->_get_url( URL_PLATFORM . $platform->accession );
 
168
 
 
169
  my @datasets = ();
 
170
 
 
171
  foreach my $line ( @lines ) {
 
172
    my ($dataset_acc) = $line =~ /^\!Platform_series_id = (\S+?)\s*$/;
 
173
    next unless $dataset_acc;
 
174
 
 
175
    my $dataset = Bio::Expression::DataSet->new(
 
176
                                                -accession => $dataset_acc,
 
177
                                                -platform => $platform,
 
178
                                                -db => $self,
 
179
                                               );
 
180
 
 
181
    push @datasets, $dataset;
 
182
  }
 
183
 
 
184
  return @datasets;
 
185
}
 
186
 
 
187
sub fill_sample {
 
188
  my ( $self, $sample ) = @_;
 
189
 
 
190
  my @lines = split /\n/, $self->_get_url( URL_SAMPLE. $sample->accession );
 
191
 
 
192
  foreach my $line ( @lines ) {
 
193
    if ( my ($name) = $line =~ /^\!Sample_title = (.+?)\s*$/ ) {
 
194
      $sample->name( $name );
 
195
    }
 
196
    elsif ( my ($desc) = $line =~ /^\!Sample_characteristics.*? = (.+?)\s*$/ ) {
 
197
      $sample->description( $desc );
 
198
    }
 
199
    elsif ( my ($source_name) = $line =~ /^\!Sample_source_name.*? = (.+?)\s*$/ ) {
 
200
      $sample->source_name( $source_name );
 
201
    }
 
202
    elsif ( my ($treatment_desc) = $line =~ /^\!Sample_treatment_protocol.*? = (.+?)\s*$/ ) {
 
203
      $sample->treatment_description( $treatment_desc );
 
204
    }
 
205
  }
 
206
  return 1;
 
207
}
 
208
 
 
209
sub fill_dataset {
 
210
  my ( $self, $dataset ) = @_;
 
211
 
 
212
  my @lines = split /\n/, $self->_get_url( URL_DATASET . $dataset->accession );
 
213
 
 
214
  my @samples = ();
 
215
 
 
216
  foreach my $line ( @lines ) {
 
217
    if ( my ($sample_acc) = $line =~ /^\!Series_sample_id = (\S+?)\s*$/ ) {
 
218
      my $sample = Bio::Expression::Sample->new(
 
219
                                                -accession => $sample_acc,
 
220
                                                -dataset => $dataset,
 
221
                                                -db => $self,
 
222
                                               );
 
223
      push @samples, $sample;
 
224
    }
 
225
    elsif ( my ($pubmed_acc) = $line =~ /^\!Series_pubmed_id = (.+?)\s*$/ ) {
 
226
      $dataset->pubmed_id( $pubmed_acc );
 
227
    }
 
228
    elsif ( my ($web_link) = $line =~ /^\!Series_web_link = (.+?)\s*$/ ) {
 
229
      $dataset->web_link( $web_link );
 
230
    }
 
231
    elsif ( my ($contact) = $line =~ /^\!Series_contact_name = (.+?)\s*$/ ) {
 
232
      $dataset->contact( $contact );
 
233
    }
 
234
    elsif ( my ($name) = $line =~ /^\!Series_title = (.+?)\s*$/ ) {
 
235
      $dataset->name( $name );
 
236
    }
 
237
    elsif ( my ($desc) = $line =~ /^\!Series_summary = (.+?)\s*$/ ) {
 
238
      $dataset->description( $desc );
 
239
    }
 
240
    elsif ( my ($design) = $line =~ /^\!Series_type = (.+?)\s*$/ ) {
 
241
      $dataset->design( $design );
 
242
    }
 
243
    elsif ( my ($design_desc) = $line =~ /^\!Series_overall_design = (.+?)\s*$/ ) {
 
244
      $dataset->design_description( $design_desc );
 
245
    }
 
246
  }
 
247
 
 
248
  $dataset->samples(\@samples);
 
249
}
 
250
 
 
251
#################################################
 
252
 
 
253
=head2 _platforms_doc()
 
254
 
 
255
 Usage   :
 
256
 Function:
 
257
 Example :
 
258
 Returns : an HTML document containing a table of all platforms
 
259
 Args    :
 
260
 
 
261
 
 
262
=cut
 
263
 
 
264
sub _get_url {
 
265
  my ($self,$url) = @_;
 
266
 
 
267
  my $response;
 
268
  eval {
 
269
    $response = $self->get( $url );
 
270
  };
 
271
  if( $@ ) {
 
272
    $self->warn("Can't query website: $@");
 
273
    return;
 
274
  }
 
275
  $self->debug( "resp is $response\n"); 
 
276
 
 
277
  return $response;
 
278
}
 
279
 
 
280
 
 
281
1;