[Bioperl-guts-l] bioperl-live/Bio/Tools/EUtilities/Link LinkSet.pm, NONE, 1.1 UrlLink.pm, NONE, 1.1
Christopher John Fields
cjfields at dev.open-bio.org
Sat Jun 23 00:43:07 EDT 2007
Update of /home/repository/bioperl/bioperl-live/Bio/Tools/EUtilities/Link
In directory dev.open-bio.org:/tmp/cvs-serv7006/EUtilities/Link
Added Files:
LinkSet.pm UrlLink.pm
Log Message:
eutils parsers, part of EUtilities overhaul (still need some work and tests)
--- NEW FILE: LinkSet.pm ---
# $Id: LinkSet.pm,v 1.1 2007/06/23 04:43:05 cjfields Exp $
#
# BioPerl module for Bio::Tools::EUtilities::Link::LinkSet
#
# Cared for by Chris Fields
#
# Copyright Chris Fields
#
# You may distribute this module under the same terms as perl itself
#
# POD documentation - main docs before the code
#
# Part of the EUtilities BioPerl package
=head1 NAME
Bio::Tools::EUtilities::Link::LinkSet
=head1 SYNOPSIS
...
=head1 DESCRIPTION
...
=head1 FEEDBACK
=head2 Mailing Lists
User feedback is an integral part of the
evolution of this and other Bioperl modules. Send
your comments and suggestions preferably to one
of the Bioperl mailing lists. Your participation
is much appreciated.
bioperl-l at lists.open-bio.org - General discussion
http://www.bioperl.org/wiki/Mailing_lists - About the mailing lists
=head2 Reporting Bugs
Report bugs to the Bioperl bug tracking system to
help us keep track the bugs and their resolution.
Bug reports can be submitted via the web.
http://bugzilla.open-bio.org/
=head1 AUTHOR
Email cjfields at uiuc dot edu
=head1 APPENDIX
The rest of the documentation details each of the
object methods. Internal methods are usually
preceded with a _
=cut
# Let the code begin...
package Bio::Tools::EUtilities::Link::LinkSet;
use base qw(Bio::Root::Root Bio::Tools::EUtilities::HistoryI);
use Bio::Tools::EUtilities::Link::UrlLink;
use Bio::Tools::EUtilities::Info::LinkInfo;
use Data::Dumper;
sub new {
my ($class, at args) = @_;
my $self = $class->SUPER::new(@args);
my ($type) = $self->_rearrange([qw(DATATYPE)], at args);
$type ||= 'linkset';
$self->eutil('elink');
$self->datatype($type);
return $self;
}
=head2 get_ids
Title : get_ids
Usage : my @ids = $linkset->get_ids
Function : returns list of retrieved IDs
Returns : array or array ref of IDs
Args : none
=cut
sub get_ids {
my $self = shift;
unless ($self->{'_sorted_id'}) {
@{$self->{'_sorted_id'}} =
sort {
$self->{'_id'}->{$a}->[0] <=>
$self->{'_id'}->{$b}->[0]
} keys %{$self->{'_id'}};
}
return wantarray ? @{$self->{'_sorted_id'}} : $self->{'_sorted_id'};
}
=head2 get_dbto
Title : get_dbto
Usage : my $string = $linkset->get_dbto;
Function : retrieve database referred to for this linkset
Returns : string
Args : none
=cut
sub get_dbto { return shift->{'_dbto'} }
=head2 get_dbfrom
Title : get_dbfrom
Usage : my $string = $linkset->get_dbfrom;
Function : retrieve originating database for this linkset
Returns : string
Args : none
=cut
sub get_dbfrom { return shift->{'_dbfrom'} }
=head2 get_linkname
Title : get_linkname
Usage : my $string = $linkset->get_linkname;
Function : retrieve eutil-compatible link name
Returns : string
Args : none
=cut
sub get_linkname { return shift->{'_linkname'} }
=head2 get_submitted_ids
Title : get_submitted_ids
Usage : my $string = $linkset->get_submitted_ids;
Function : retrieve original ID list
Returns : string
Args : none
=cut
sub get_submitted_ids {
my $self = shift;
my $datatype = $self->datatype;
if ($datatype eq 'idcheck' || $datatype eq 'urllink') {
return wantarray ? $self->get_ids : [$self->get_ids];
} elsif ($self->{'_submitted_ids'}) {
return wantarray ? @{$self->{'_submitted_ids'}} : $self->{'_submitted_ids'};
} else {
return wantarray ? () : undef;
}
}
=head2 has_scores
Title : has_scores
Usage : if (my $linkset->has_scores) {...}
Function : returns TRUE if score data is present
Returns : Boolean
Args : none
=cut
sub has_scores {
my $self = shift;
return exists $self->{'_has_scores'} ? $self->{'_has_scores'} : 0;
}
=head2 get_scores
Title : get_scores
Usage : %scores = $linkset->get_scores;
Function : returns flattened list or hash ref containing ID => score pairs
Returns : hash or hash ref (based on list or scalar context)
Args : none
=cut
sub get_scores {
my $self = shift;
# do we want to cache this or generate only when needed? Likely won't be
# called more than once...
return unless $self->has_scores;
my %scores = map {$_ => $self->{'_id'}->{$_}->[1]} keys %{$self->{'_id'}};
return wantarray ? %scores : \%scores;
}
=head2 get_score_by_id
Title : get_score_by_id
Usage : $score = $linkset->get_score_by_id($id);
Function : returns the score for a particular primary ID
Returns : integer
Args : [REQUIRED] Primary ID for the score lookup
=cut
sub get_score_by_id {
my ($self, $id) = @_;
($id && exists $self->{'_id'}->{$id}) ? return $self->{'_id'}->{$id}->[1] :
return;
}
=head2 has_linkout
Title : has_linkout
Usage : if ($linkset->has_linkout) {...}
Function : returns TRUE if the single ID present in this linkset has a linkout
Returns : boolean
Args : none (uses the ID in get_ids(), which for these cases is always
only one)
=cut
sub has_linkout {
my $self = shift;
if (exists $self->{'_haslinkout'}) {
return $self->{'_haslinkout'} eq 'Y' ? 1 : 0;
} else {
$self->warn('No data present; did you use cmd lcheck?');
return;
}
}
=head2 has_neighbor
Title : has_neighbor
Usage : if ($linkset->has_neighbor) {...}
Function : returns TRUE if the single ID present in this linkset has a neighbor
in the same database
Returns : boolean
Args : none (uses the ID in get_ids(), which for these cases is always
only one)
=cut
sub has_neighbor {
my $self = shift;
if (exists $self->{'_hasneighbor'}) {
return $self->{'_hasneighbor'} eq 'Y' ? 1 : 0;
} else {
$self->warn('No data present; did you use cmd ncheck?');
return;
}
}
=head2 next_UrlLink
Title : next_UrlLink
Usage : while (my $url = $linkset->next_UrlLink) {...}
Function : iterate through UrlLink objects
Returns : Bio::Tools::EUtilities::Link::UrlLink
Args :
=cut
sub next_UrlLink {
my $self = shift;
unless ($self->{"_urllinks_it"}) {
my @ul = $self->get_UrlLinks;
$self->{"_urllinks_it"} = sub {return shift @ul}
}
$self->{'_urllinks_it'}->();
}
=head2 get_UrlLinks
Title : get_UrlLinks
Usage : my @urls = $linkset->get_UrlLinks
Function : returns all UrlLink objects
Returns : list of Bio::Tools::EUtilities::Link::UrlLink
Args :
=cut
sub get_UrlLinks {
my $self = shift;
return ref $self->{'_urllinks'} ? @{ $self->{'_urllinks'} } : return;
}
=head2 next_LinkInfo
Title : next_LinkInfo
Usage : while (my $info = $linkset->next_LinkInfo) {...}
Function : iterate through LinkInfo objects
Returns : Bio::Tools::EUtilities::Link::LinkInfo
Args :
=cut
sub next_LinkInfo {
my $self = shift;
unless ($self->{"_linkinfo_it"}) {
my @li = $self->get_LinkInfo;
$self->{"_linkinfo_it"} = sub {return shift @li}
}
$self->{'_linkinfo_it'}->();
}
=head2 get_LinkInfo
Title : get_LinkInfo
Usage : my @urls = $linkset->get_LinkInfo
Function : returns all LinkInfo objects
Returns : list of Bio::Tools::EUtilities::Link::LinkInfo
Args :
=cut
sub get_LinkInfo {
return ref $self->{'_linkinfo'} ? @{ $self->{'_linkinfo'} } : return;
}
# private methods and handlers
{
my %DATA_HANDLER = (
'IdList' => \&_add_submitted_ids,
'Id' => \&_add_retrieved_ids,
'LinkInfo' => \&_add_linkinfo,
'Link' => \&_add_retrieved_ids,
'ObjUrl' => \&_add_objurls,
);
sub _add_data {
my ($self, $data) = @_;
for my $key (qw(IdList Link Id ObjUrl LinkInfo)) {
next if !exists $data->{$key};
my $handler = $DATA_HANDLER{$key};
$self->$handler($data);
delete $data->{$key};
}
# map the rest
if ($self->datatype eq 'idcheck' && exists $data->{content}) {
%{$self->{'_id'} } = ($data->{content} => [1]);
delete $data->{content}
}
map {$self->{'_'.lc $_} = $data->{$_}} keys %$data;
}
}
sub _add_submitted_ids {
my ($self, $data) = @_;
@{$self->{'_submitted_ids'}} = @{$data->{IdList}->{Id}} ;
}
sub _add_retrieved_ids {
my ($self, $data) = @_;
# map all IDs to deal with possible scores
# ID => {'count' = POSITION, 'score' => SCORE}
if (exists $data->{Link}) {
my $ct = 0;
for my $link (@{$data->{Link}}) {
if (exists $link->{Score}) {
$self->{'_has_scores'}++;
$self->{'_id'}->{$link->{Id}->[0]} = [ $ct++,$link->{Score}];
} else {
$self->{'_id'}->{$link->{Id}->[0]} = [ $ct++ ];
}
}
}
elsif (exists $data->{Id}) { # urls
%{$self->{'_id'} } = ($data->{Id}->[0] => [1]);
}
}
sub _add_objurls {
my ($self, $data) = @_;
for my $urldata (@{$data->{ObjUrl}}) {
my $obj = Bio::Tools::EUtilities::Link::UrlLink->new(-eutil => 'elink',
-datatype => 'urldata',
-verbose => $self->verbose
);
$obj->_add_data($urldata);
push @{$self->{'_urllinks'}}, $obj;
}
}
sub _add_linkinfo {
my ($self, $data) = @_;
for my $linkinfo (@{$data->{LinkInfo}}) {
my $obj = Bio::Tools::EUtilities::Info::LinkInfo->new(-eutil => 'elink',
-datatype => 'linkinfo',
-verbose => $self->verbose
);
$obj->_add_data($linkinfo);
push @{$self->{'_linkinfo'}}, $obj;
}
}
1;
__END__
--- NEW FILE: UrlLink.pm ---
# $Id: UrlLink.pm,v 1.1 2007/06/23 04:43:05 cjfields Exp $
#
# BioPerl module for Bio::Tools::EUtilities::Link::UrlLink
#
# Cared for by Chris Fields
#
# Copyright Chris Fields
#
# You may distribute this module under the same terms as perl itself
#
# POD documentation - main docs before the code
#
# Part of the EUtilities BioPerl package
=head1 NAME
Bio::Tools::EUtilities::Link::UrlLink
=head1 SYNOPSIS
...
=head1 DESCRIPTION
...
=head1 FEEDBACK
=head2 Mailing Lists
User feedback is an integral part of the
evolution of this and other Bioperl modules. Send
your comments and suggestions preferably to one
of the Bioperl mailing lists. Your participation
is much appreciated.
bioperl-l at lists.open-bio.org - General discussion
http://www.bioperl.org/wiki/Mailing_lists - About the mailing lists
=head2 Reporting Bugs
Report bugs to the Bioperl bug tracking system to
help us keep track the bugs and their resolution.
Bug reports can be submitted via the web.
http://bugzilla.open-bio.org/
=head1 AUTHOR
Email cjfields at uiuc dot edu
=head1 APPENDIX
The rest of the documentation details each of the
object methods. Internal methods are usually
preceded with a _
=cut
# Let the code begin...
package Bio::Tools::EUtilities::Link::UrlLink;
use base qw(Bio::Root::Root Bio::Tools::EUtilities::EUtilDataI);
use Data::Dumper;
=head2 get_attribute
Title : get_attribute
Usage :
Function :
Returns :
Args :
=cut
sub get_attribute { return shift->{'_attribute'}; }
=head2 get_icon_url
Title : get_icon_url
Usage :
Function :
Returns :
Args :
=cut
sub get_iconurl { return shift->{'_iconurl'}; }
=head2 get_subject_type
Title :
Usage :
Function :
Returns :
Args :
=cut
sub get_subject_type { return shift->{'_subjecttype'}; }
=head2 get_url
Title : get_url
Usage :
Function :
Returns :
Args :
=cut
sub get_url { return shift->{'_url'}; }
=head2 get_link_name
Title : get_link_name
Usage :
Function :
Returns :
Args :
=cut
sub get_link_name { return shift->{'_linkname'}; }
=head2 get_provider_name
Title : get_provider_name
Usage :
Function :
Returns :
Args :
=cut
sub get_provider_name { return shift->{'_provider_name'}; }
=head2 get_provider_abbr
Title : get_provider_abbr
Usage :
Function :
Returns :
Args :
=cut
sub get_provider_abbr { return shift->{'_provider_nameabbr'}; }
=head2 get_provider_id
Title : get_provider_id
Usage :
Function :
Returns :
Args :
=cut
sub get_provider_id { return shift->{'_provider_id'}[0]; }
=head2 get_provider_iconurl
Title : get_provider_iconurl
Usage :
Function :
Returns :
Args :
=cut
sub get_provider_iconurl { return shift->{'_provider_iconurl'}; }
=head2 get_provider_url
Title : get_provider_url
Usage :
Function :
Returns :
Args :
=cut
sub get_provider_url { return shift->{'_provider_url'}; }
# private method
sub _add_data {
my ($self, $data) = @_;
if (exists $data->{Provider}) {
map {$self->{'_provider_'.lc $_} = $data->{Provider}->{$_};
} keys %{$data->{Provider}};
delete $data->{Provider};
}
map {$self->{'_'.lc $_} = $data->{$_} if $data->{$_}} keys %$data;
}
1;
__END__
More information about the Bioperl-guts-l
mailing list