← Back to branch summary

~ubuntu-branches/ubuntu/saucy/bioperl/saucy-proposed

« back to all changes in this revision

Viewing changes to Bio/Tools/EUtilities/Link/LinkSet.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2009-03-10 07:19:11 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20090310071911-fukqzw54pyb1f0bd
Tags: 1.6.0-2
https://launchpad.net/bugs/324001
* Removed patch system (not used):
  - removed instuctions in debian/rules;
  - removed quilt from Build-Depends in debian/control.
* Re-enabled tests:
  - uncommented test command in debian/rules;
  - uncommented previously missing build-dependencies in debian/control.
  - Re-enabled tests and uncommented build-dependencies accordingly.
* Removed libmodule-build-perl and libtest-harness-perl from
  Build-Depends-Indep (provided by perl-modules).
* Better cleaning of empty directories using find -type d -empty -delete
  instead of rmdir in debian/rules (LP: #324001).

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/Tools/EUtilities/Link/LinkSet.pm
 
1
# $Id: LinkSet.pm 15163 2008-12-15 18:39:09Z cjfields $
 
2
#
 
3
# BioPerl module for Bio::Tools::EUtilities::Link::LinkSet
 
4
#
 
5
# Cared for by Chris Fields
 
6
#
 
7
# Copyright Chris Fields
 
8
#
 
9
# You may distribute this module under the same terms as perl itself
 
10
#
 
11
# POD documentation - main docs before the code
 
12
# 
 
13
# Part of the EUtilities BioPerl package
 
14
 
 
15
=head1 NAME
 
16
 
 
17
Bio::Tools::EUtilities::Link::LinkSet
 
18
 
 
19
=head1 SYNOPSIS
 
20
 
 
21
  # ...
 
22
 
 
23
=head1 DESCRIPTION
 
24
 
 
25
  # ...
 
26
 
 
27
=head1 FEEDBACK
 
28
 
 
29
=head2 Mailing Lists
 
30
 
 
31
User feedback is an integral part of the
 
32
evolution of this and other Bioperl modules. Send
 
33
your comments and suggestions preferably to one
 
34
of the Bioperl mailing lists. Your participation
 
35
is much appreciated.
 
36
 
 
37
  bioperl-l@lists.open-bio.org               - General discussion
 
38
  http://www.bioperl.org/wiki/Mailing_lists  - About the mailing lists
 
39
 
 
40
=head2 Reporting Bugs
 
41
 
 
42
Report bugs to the Bioperl bug tracking system to
 
43
help us keep track the bugs and their resolution.
 
44
Bug reports can be submitted via the web.
 
45
 
 
46
  http://bugzilla.open-bio.org/
 
47
 
 
48
=head1 AUTHOR 
 
49
 
 
50
Email cjfields at uiuc dot edu
 
51
 
 
52
=head1 APPENDIX
 
53
 
 
54
The rest of the documentation details each of the
 
55
object methods. Internal methods are usually
 
56
preceded with a _
 
57
 
 
58
=cut
 
59
 
 
60
# Let the code begin...
 
61
 
 
62
package Bio::Tools::EUtilities::Link::LinkSet;
 
63
use strict;
 
64
use warnings;
 
65
 
 
66
use base qw(Bio::Root::Root Bio::Tools::EUtilities::HistoryI);
 
67
use Bio::Tools::EUtilities::Link::UrlLink;
 
68
use Bio::Tools::EUtilities::Info::LinkInfo;
 
69
 
 
70
sub new {
 
71
    my ($class,@args) = @_;
 
72
    my $self = $class->SUPER::new(@args);
 
73
    my ($type) = $self->_rearrange([qw(DATATYPE)],@args);
 
74
    $type ||= 'linkset';
 
75
    $self->eutil('elink');
 
76
    $self->datatype($type);
 
77
    return $self;
 
78
}
 
79
 
 
80
=head2 get_ids
 
81
 
 
82
 Title    : get_ids
 
83
 Usage    : my @ids = $linkset->get_ids
 
84
 Function : returns list of retrieved IDs
 
85
 Returns  : array of IDs
 
86
 Args     : none
 
87
 Notes    : Cmd                   Description
 
88
            acheck                same as get_submitted_ids
 
89
            lcheck                same as get_submitted_ids
 
90
            ncheck                same as get_submitted_ids
 
91
            prlinks               same as get_submitted_ids
 
92
            llinks                same as get_submitted_ids
 
93
            llinkslib             same as get_submitted_ids
 
94
            neighbor              linked IDs for database in get_database
 
95
            neighbor_history      linked IDs for database in get_database
 
96
 
 
97
=cut
 
98
 
 
99
sub get_ids {
 
100
    my $self = shift;
 
101
    unless ($self->{'_sorted_id'}) {
 
102
        @{$self->{'_sorted_id'}} =
 
103
            sort {
 
104
                $self->{'_id'}->{$a}->[0] <=>
 
105
                $self->{'_id'}->{$b}->[0]
 
106
            } keys %{$self->{'_id'}};
 
107
    }
 
108
    return @{$self->{'_sorted_id'}};
 
109
}
 
110
 
 
111
=head2 get_database
 
112
 
 
113
 Title    : get_database
 
114
 Usage    : my $db = $info->get_database;
 
115
 Function : returns single database name (eutil-compatible).  This is the
 
116
            queried database. For elinks (which have 'db' and 'dbfrom')
 
117
            this is equivalent to db/dbto (use get_dbfrom() to for the latter).
 
118
            Note that this only returns the first db; in some cases this may
 
119
            not be what you want (when multiple dbs are queried, for instance)
 
120
 Returns  : string
 
121
 Args     : none
 
122
 Notes    : with all elink cmd arguments
 
123
 
 
124
=cut
 
125
 
 
126
sub get_database {
 
127
    return ($_[0]->get_databases)[0];
 
128
}
 
129
 
 
130
=head2 get_db (alias for get_database)
 
131
 
 
132
=cut
 
133
 
 
134
sub get_db {
 
135
    return shift->get_database;
 
136
}
 
137
 
 
138
=head2 get_dbto (alias for get_database)
 
139
 
 
140
=cut
 
141
 
 
142
sub get_dbto {
 
143
    return shift->get_database;
 
144
}
 
145
 
 
146
=head2 get_databases
 
147
 
 
148
 Title    : get_databases
 
149
 Usage    : my $string = $linkset->get_databases;
 
150
 Function : retrieve databases referred to for this linkset
 
151
            these may be present as a single database or embedded in 
 
152
 Returns  : array of strings
 
153
 Args     : none
 
154
 
 
155
=cut
 
156
 
 
157
sub get_databases {
 
158
    my $self = shift;
 
159
    my %tmp;
 
160
    my @dbs = sort map {$_->get_database} 
 
161
        grep {!$tmp{$_->get_database}++} ($self->get_LinkInfo);
 
162
    unshift @dbs, $self->{'_dbto'} if $self->{'_dbto'} && !$tmp{$self->{'_dbto'}}++;
 
163
    return @dbs;
 
164
}
 
165
 
 
166
=head2 get_dbs (alias for get_databases)
 
167
 
 
168
=cut
 
169
 
 
170
sub get_dbs {
 
171
    return shift->get_databases;
 
172
}
 
173
 
 
174
=head2 get_dbfrom
 
175
 
 
176
 Title    : get_dbfrom
 
177
 Usage    : my $string = $linkset->get_dbfrom;
 
178
 Function : retrieve originating database for this linkset
 
179
 Returns  : string
 
180
 Args     : none
 
181
 
 
182
=cut
 
183
 
 
184
sub get_dbfrom { return shift->{'_dbfrom'} }
 
185
 
 
186
=head2 get_link_names
 
187
 
 
188
 Title    : get_link_names
 
189
 Usage    : my $string = $linkset->get_link_names;
 
190
 Function : retrieve eutil-compatible link names
 
191
 Returns  : array of strings
 
192
 Args     : none
 
193
 Notes    : Each LinkSet can hold multiple LinkInfo objects (each containing
 
194
            a link name). Also, some LinkSets define a single link name. This
 
195
            returns an array with all unique linknames globbed both sources, if
 
196
            present and defined
 
197
 
 
198
=cut
 
199
 
 
200
sub get_link_names {
 
201
    my ($self) = shift;
 
202
    my %tmps;
 
203
    my @lns;
 
204
    if ($self->{'_linkname'}) {
 
205
        push @lns, $self->{'_linkname'};
 
206
        $tmps{$self->{'_linkname'}}++;
 
207
    }
 
208
    push @lns, map {$_->get_link_name} $self->get_LinkInfo;
 
209
    return @lns;
 
210
}
 
211
 
 
212
=head2 get_link_name
 
213
 
 
214
 Title    : get_link_name
 
215
 Usage    : my $string = $linkset->get_link_name;
 
216
 Function : retrieve eutil-compatible link name
 
217
 Returns  : single link name
 
218
 Args     : none
 
219
 
 
220
=cut
 
221
 
 
222
sub get_link_name {
 
223
    return ($_[0]->get_linknames)[0];
 
224
}
 
225
 
 
226
=head2 get_submitted_ids
 
227
 
 
228
 Title    : get_submitted_ids
 
229
 Usage    : my $string = $linkset->get_submitted_ids;
 
230
 Function : retrieve original ID list
 
231
 Returns  : string
 
232
 Args     : none
 
233
 
 
234
=cut
 
235
 
 
236
sub get_submitted_ids {
 
237
    my $self = shift;
 
238
    my $datatype = $self->datatype;
 
239
    if ($datatype eq 'idcheck' || $datatype eq 'urllink') {
 
240
        return $self->get_ids;
 
241
    } elsif ($self->{'_submitted_ids'}) {
 
242
        return @{$self->{'_submitted_ids'}};
 
243
    } else {
 
244
        return ();
 
245
    }
 
246
}
 
247
 
 
248
=head2 has_scores
 
249
 
 
250
 Title    : has_scores
 
251
 Usage    : if (my $linkset->has_scores) {...}
 
252
 Function : returns TRUE if score data is present 
 
253
 Returns  : Boolean 
 
254
 Args     : none
 
255
 
 
256
=cut
 
257
 
 
258
sub has_scores {
 
259
    my $self = shift;
 
260
    return exists $self->{'_has_scores'} ? 1 : 0;
 
261
}
 
262
 
 
263
=head2 get_scores
 
264
 
 
265
 Title    : get_scores
 
266
 Usage    : %scores = $linkset->get_scores;
 
267
 Function : returns flattened list or hash ref containing ID => score pairs
 
268
 Returns  : hash or hash ref (based on list or scalar context)
 
269
 Args     : none
 
270
 
 
271
=cut
 
272
 
 
273
sub get_scores {
 
274
    my $self = shift;
 
275
    # do we want to cache this or generate only when needed?  Likely won't be
 
276
    # called more than once...
 
277
    return unless $self->has_scores;
 
278
    my %scores = map {$_ => $self->{'_id'}->{$_}->[1]} keys %{$self->{'_id'}};
 
279
    return %scores; 
 
280
}
 
281
 
 
282
=head2 get_score_by_id
 
283
 
 
284
 Title    : get_score_by_id
 
285
 Usage    : $score = $linkset->get_score_by_id($id);
 
286
 Function : returns the score for a particular primary ID
 
287
 Returns  : integer
 
288
 Args     : [REQUIRED] Primary ID for the score lookup
 
289
 
 
290
=cut
 
291
 
 
292
sub get_score_by_id {
 
293
    my ($self, $id) = @_;
 
294
    ($id && exists $self->{'_id'}->{$id}) ? return $self->{'_id'}->{$id}->[1] :
 
295
        return;
 
296
}
 
297
 
 
298
=head2 has_linkout
 
299
 
 
300
 Title    : has_linkout
 
301
 Usage    : if ($linkset->has_linkout) {...}
 
302
 Function : returns TRUE if the single ID present in this linkset has a linkout
 
303
 Returns  : boolean
 
304
 Args     : none
 
305
 Notes    : this checks cmd=lcheck (boolean for a linkout) and also backchecks
 
306
            cmd=acheck for databases with name 'LinkOut'
 
307
 
 
308
=cut
 
309
 
 
310
sub has_linkout {
 
311
    my $self = shift;
 
312
    if (exists $self->{'_haslinkout'}) {
 
313
        return $self->{'_haslinkout'} eq 'Y' ? 1 : 0;
 
314
    } else  {
 
315
        return (grep {$_ eq 'LinkOut'} $self->get_databases) ? 1 : 0;
 
316
    } 
 
317
}
 
318
 
 
319
=head2 has_neighbor
 
320
 
 
321
 Title    : has_neighbor
 
322
 Usage    : if ($linkset->has_neighbor) {...}
 
323
 Function : returns TRUE if the single ID present in this linkset has a neighbor
 
324
            in the same database
 
325
 Returns  : boolean
 
326
 Args     : none
 
327
 Notes    : this checks cmd=ncheck (boolean for a neighbor in same database); no
 
328
            other checks performed at this time
 
329
 
 
330
=cut
 
331
 
 
332
sub has_neighbor {
 
333
    my $self = shift;
 
334
    if (exists $self->{'_hasneighbor'}) {
 
335
        return $self->{'_hasneighbor'} eq 'Y' ? 1 : 0;
 
336
    } else {
 
337
        return 0;
 
338
    }
 
339
}
 
340
 
 
341
=head2 next_UrlLink
 
342
 
 
343
 Title    : next_UrlLink
 
344
 Usage    : while (my $url = $linkset->next_UrlLink) {...}
 
345
 Function : iterate through UrlLink objects
 
346
 Returns  : Bio::Tools::EUtilities::Link::UrlLink
 
347
 Args     : 
 
348
 
 
349
=cut
 
350
 
 
351
sub next_UrlLink {
 
352
    my $self = shift;
 
353
    unless ($self->{"_urllinks_it"}) {
 
354
        my @ul = $self->get_UrlLinks;
 
355
        $self->{"_urllinks_it"} = sub {return shift @ul}
 
356
    }
 
357
    $self->{'_urllinks_it'}->();
 
358
}
 
359
 
 
360
=head2 get_UrlLinks
 
361
 
 
362
 Title    : get_UrlLinks
 
363
 Usage    : my @urls = $linkset->get_UrlLinks
 
364
 Function : returns all UrlLink objects
 
365
 Returns  : list of Bio::Tools::EUtilities::Link::UrlLink
 
366
 Args     : 
 
367
 
 
368
=cut
 
369
 
 
370
sub get_UrlLinks {
 
371
    my $self = shift;
 
372
    return ref $self->{'_urllinks'} ? @{ $self->{'_urllinks'} } : return;
 
373
}
 
374
 
 
375
=head2 next_LinkInfo
 
376
 
 
377
 Title    : next_LinkInfo
 
378
 Usage    : while (my $info = $linkset->next_LinkInfo) {...}
 
379
 Function : iterate through LinkInfo objects
 
380
 Returns  : Bio::Tools::EUtilities::Link::LinkInfo
 
381
 Args     : 
 
382
 
 
383
=cut
 
384
 
 
385
sub next_LinkInfo {
 
386
    my $self = shift;
 
387
    unless ($self->{"_linkinfo_it"}) {
 
388
        my @li = $self->get_LinkInfo;
 
389
        $self->{"_linkinfo_it"} = sub {return shift @li}
 
390
    }
 
391
    $self->{'_linkinfo_it'}->();
 
392
}
 
393
 
 
394
=head2 get_LinkInfo
 
395
 
 
396
 Title    : get_LinkInfo
 
397
 Usage    : my @links = $linkset->get_LinkInfo
 
398
 Function : returns all LinkInfo objects
 
399
 Returns  : list of Bio::Tools::EUtilities::Link::LinkInfo
 
400
 Args     : 
 
401
 
 
402
=cut
 
403
 
 
404
sub get_LinkInfo {
 
405
    my $self = shift;
 
406
    return ref $self->{'_linkinfo'} ? @{ $self->{'_linkinfo'} } : return ();
 
407
}
 
408
 
 
409
=head2 rewind
 
410
 
 
411
 Title    : rewind
 
412
 Usage    : $info->rewind() # rewinds all (default)
 
413
            $info->rewind('links') # rewinds only links
 
414
 Function : 'rewinds' (resets) specified interators (all if no arg)
 
415
 Returns  : none
 
416
 Args     : [OPTIONAL] String: 
 
417
            'all'       - all iterators (default)
 
418
            'linkinfo' or 'linkinfos'  - LinkInfo objects only
 
419
            'urllinks'   - UrlLink objects only
 
420
 
 
421
=cut
 
422
 
 
423
{
 
424
    my %VALID_DATA = ('linkinfo' => 'linkinfo',
 
425
                      'linkinfos' => 'linkinfo',
 
426
                      'urllinks' => 'urllinks');
 
427
    
 
428
    sub rewind {
 
429
        my ($self, $arg) = @_;
 
430
        $arg ||= 'all';
 
431
        if (exists $VALID_DATA{$arg}) {
 
432
            delete $self->{'_'.$arg.'_it'};
 
433
        } elsif ($arg eq 'all') {
 
434
            delete $self->{'_'.$_.'_it'} for values %VALID_DATA;
 
435
        }
 
436
    }
 
437
}
 
438
 
 
439
# private methods and handlers
 
440
 
 
441
{
 
442
    my %DATA_HANDLER = (
 
443
        'IdList' => \&_add_submitted_ids,
 
444
        'Id'     => \&_add_retrieved_ids,
 
445
        'LinkInfo' => \&_add_linkinfo,
 
446
        'Link'   => \&_add_retrieved_ids,
 
447
        'ObjUrl' => \&_add_objurls,
 
448
        );
 
449
 
 
450
sub _add_data {
 
451
    my ($self, $data) = @_;
 
452
    for my $key (qw(IdList Link Id ObjUrl LinkInfo)) {
 
453
        next if !exists $data->{$key};
 
454
        my $handler = $DATA_HANDLER{$key};
 
455
        $self->$handler($data);
 
456
        delete $data->{$key};
 
457
    }
 
458
    # map the rest
 
459
    if ($self->datatype eq 'idcheck' && exists $data->{content}) {
 
460
        %{$self->{'_id'} } = ($data->{content} => [1]);
 
461
        delete $data->{content}
 
462
    }
 
463
    map {$self->{'_'.lc $_} = $data->{$_}} keys %$data;
 
464
}
 
465
 
 
466
}
 
467
 
 
468
sub _add_submitted_ids {
 
469
    my ($self, $data) = @_;
 
470
    @{$self->{'_submitted_ids'}} = @{$data->{IdList}->{Id}} ;
 
471
}
 
472
 
 
473
sub _add_retrieved_ids {
 
474
    my ($self, $data) = @_;
 
475
    # map all IDs to deal with possible scores
 
476
    # ID => {'count' = POSITION, 'score' => SCORE}
 
477
    if (exists $data->{Link}) {
 
478
        my $ct = 0;
 
479
        for my $link (@{$data->{Link}}) {
 
480
            if (exists $link->{Score}) {
 
481
                $self->{'_has_scores'}++;
 
482
                $self->{'_id'}->{$link->{Id}->[0]} = [ $ct++,$link->{Score}];
 
483
            } else {
 
484
                $self->{'_id'}->{$link->{Id}->[0]} = [ $ct++ ];
 
485
            }
 
486
        }
 
487
    }
 
488
    elsif (exists $data->{Id}) { # urls
 
489
        %{$self->{'_id'} } = ($data->{Id}->[0] => [1]);
 
490
    }
 
491
}
 
492
 
 
493
sub _add_objurls {
 
494
    my ($self, $data) = @_;
 
495
    for my $urldata (@{$data->{ObjUrl}}) {
 
496
        $urldata->{dbfrom} = $data->{DbFrom} if exists $data->{DbFrom};
 
497
        my $obj = Bio::Tools::EUtilities::Link::UrlLink->new(-eutil => 'elink',
 
498
                                                             -datatype => 'urldata',
 
499
                                                             -verbose => $self->verbose
 
500
                                                             );
 
501
        $obj->_add_data($urldata);
 
502
        push @{$self->{'_urllinks'}}, $obj;
 
503
    }
 
504
}
 
505
 
 
506
sub _add_linkinfo {
 
507
    my ($self, $data) = @_;
 
508
    for my $linkinfo (@{$data->{LinkInfo}}) {
 
509
        $linkinfo->{dbfrom} = $data->{DbFrom} if exists $data->{DbFrom};
 
510
        my $obj = Bio::Tools::EUtilities::Info::LinkInfo->new(-eutil => 'elink',
 
511
                                                             -datatype => 'linkinfo',
 
512
                                                             -verbose => $self->verbose
 
513
                                                             );
 
514
        $obj->_add_data($linkinfo);
 
515
        push @{$self->{'_linkinfo'}}, $obj;
 
516
    }
 
517
}
 
518
 
 
519
=head2 to_string
 
520
 
 
521
 Title    : to_string
 
522
 Usage    : $foo->to_string()
 
523
 Function : converts current object to string
 
524
 Returns  : none
 
525
 Args     : (optional) simple data for text formatting
 
526
 Note     : Used generally for debugging and for various print methods
 
527
 
 
528
=cut
 
529
 
 
530
sub to_string {
 
531
    my $self = shift;
 
532
    my $level = shift || 0;
 
533
    my $pad = 20 - $level;
 
534
    #        order     method                    name
 
535
    my %tags = (1 => ['get_databases'         => 'DB'],
 
536
                2 => ['get_ids'               => 'ID'],
 
537
                3 => ['get_link_names'        => 'Link Names'],
 
538
                5 => ['get_submitted_ids'     => 'Submitted IDs'],
 
539
                6 => ['has_scores'            => 'Scores?'],
 
540
                7 => ['has_linkout'           => 'LinkOut?'],
 
541
                8 => ['has_neighbor'          => 'DB Neighbors?'],
 
542
                9 => ['get_webenv'            => 'WebEnv'],
 
543
                10 => ['get_query_key'        => 'Key'],
 
544
                );
 
545
    my $string;
 
546
    for my $tag (sort {$a <=> $b} keys %tags) {
 
547
        my ($m, $nm) = ($tags{$tag}->[0], $tags{$tag}->[1]);
 
548
        # using this awkward little construct to deal with both lists and scalars
 
549
        my @content = grep {defined $_} $self->$m();
 
550
        next unless @content;
 
551
        $string .= sprintf("%-*s%-*s%s\n",
 
552
            $level, '',
 
553
            $pad, $nm,
 
554
            $self->_text_wrap(':',
 
555
                 ' ' x ($pad).':',
 
556
                 join(', ',@content)));
 
557
    }
 
558
    while (my $li = $self->next_LinkInfo) {
 
559
        $string .= $li->to_string(4);
 
560
    }
 
561
    while (my $ui = $self->next_UrlLink) {
 
562
        $string .= $ui->to_string(4);
 
563
    }
 
564
    if ($self->has_scores) {
 
565
        $string .= "Scores:\n";
 
566
        my %scores = $self->get_scores;
 
567
        $string .= sprintf("%-*s%-*s%s\n",
 
568
            $level + 4, '',
 
569
            $pad - 4, 'ID', 'Score'
 
570
            );        
 
571
        for my $id ($self->get_ids) {
 
572
            $string .= sprintf("%-*s%-*s%s\n",
 
573
                $level + 4, '',
 
574
                $pad - 4, $id, $scores{$id}
 
575
                );
 
576
        }
 
577
    }
 
578
    $string .= "\n";
 
579
    return $string;
 
580
}
 
581
 
 
582
1;
 
583