Bio::Tools::EUtilities::Link::LinkSet - class for EUtils LinkSets

  # ...

  # ...

  bioperl-l@lists.open-bio.org               - General discussion
  http://www.bioperl.org/wiki/Mailing_lists  - About the mailing lists

  https://redmine.open-bio.org/projects/bioperl/

 Title    : get_ids
 Usage    : my @ids = $linkset->get_ids
 Function : returns list of retrieved IDs
 Returns  : array of IDs
 Args     : none
 Notes    : Cmd                   Description
            acheck                same as get_submitted_ids
            lcheck                same as get_submitted_ids
            ncheck                same as get_submitted_ids
            prlinks               same as get_submitted_ids
            llinks                same as get_submitted_ids
            llinkslib             same as get_submitted_ids
            neighbor              linked IDs for database in get_database
            neighbor_history      linked IDs for database in get_database

 Title    : get_database
 Usage    : my $db = $info->get_database;
 Function : returns single database name (eutil-compatible).  This is the
            queried database. For elinks (which have 'db' and 'dbfrom')
            this is equivalent to db/dbto (use get_dbfrom() to for the latter).
            Note that this only returns the first db; in some cases this may
            not be what you want (when multiple dbs are queried, for instance)
 Returns  : string
 Args     : none
 Notes    : with all elink cmd arguments

 Title    : get_databases
 Usage    : my $string = $linkset->get_databases;
 Function : retrieve databases referred to for this linkset
            these may be present as a single database or embedded in 
 Returns  : array of strings
 Args     : none

 Title    : get_dbfrom
 Usage    : my $string = $linkset->get_dbfrom;
 Function : retrieve originating database for this linkset
 Returns  : string
 Args     : none

 Title    : get_link_names
 Usage    : my $string = $linkset->get_link_names;
 Function : retrieve eutil-compatible link names
 Returns  : array of strings
 Args     : none
 Notes    : Each LinkSet can hold multiple LinkInfo objects (each containing
            a link name). Also, some LinkSets define a single link name. This
            returns an array with all unique linknames globbed both sources, if
            present and defined

 Title    : get_link_name
 Usage    : my $string = $linkset->get_link_name;
 Function : retrieve eutil-compatible link name
 Returns  : single link name
 Args     : none

 Title    : get_submitted_ids
 Usage    : my $string = $linkset->get_submitted_ids;
 Function : retrieve original ID list
 Returns  : string
 Args     : none

 Title    : has_scores
 Usage    : if (my $linkset->has_scores) {...}
 Function : returns TRUE if score data is present 
 Returns  : Boolean 
 Args     : none

 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

 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

 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
 Notes    : this checks cmd=lcheck (boolean for a linkout) and also backchecks
            cmd=acheck for databases with name 'LinkOut'

 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
 Notes    : this checks cmd=ncheck (boolean for a neighbor in same database); no
            other checks performed at this time

 Title    : next_UrlLink
 Usage    : while (my $url = $linkset->next_UrlLink) {...}
 Function : iterate through UrlLink objects
 Returns  : Bio::Tools::EUtilities::Link::UrlLink
 Args     : 

 Title    : get_UrlLinks
 Usage    : my @urls = $linkset->get_UrlLinks
 Function : returns all UrlLink objects
 Returns  : list of Bio::Tools::EUtilities::Link::UrlLink
 Args     : 

 Title    : next_LinkInfo
 Usage    : while (my $info = $linkset->next_LinkInfo) {...}
 Function : iterate through LinkInfo objects
 Returns  : Bio::Tools::EUtilities::Link::LinkInfo
 Args     : 

 Title    : get_LinkInfo
 Usage    : my @links = $linkset->get_LinkInfo
 Function : returns all LinkInfo objects
 Returns  : list of Bio::Tools::EUtilities::Link::LinkInfo
 Args     : 

 Title    : rewind
 Usage    : $info->rewind() # rewinds all (default)
            $info->rewind('links') # rewinds only links
 Function : 'rewinds' (resets) specified interators (all if no arg)
 Returns  : none
 Args     : [OPTIONAL] String: 
            'all'       - all iterators (default)
            'linkinfo' or 'linkinfos'  - LinkInfo objects only
            'urllinks'   - UrlLink objects only

 Title    : to_string
 Usage    : $foo->to_string()
 Function : converts current object to string
 Returns  : none
 Args     : (optional) simple data for text formatting
 Note     : Used generally for debugging and for various print methods

#
# BioPerl module for Bio::Tools::EUtilities::Link::LinkSet
#
# Please direct questions and support issues to <bioperl-l@bioperl.org> 
#
# 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

# Let the code begin...

package Bio::Tools::EUtilities::Link::LinkSet;
use strict;
use warnings;

use base qw(Bio::Root::Root Bio::Tools::EUtilities::HistoryI);
use Bio::Tools::EUtilities::Link::UrlLink;
use Bio::Tools::EUtilities::Info::LinkInfo;

sub new {
    my ($class,@args) = @_;
    my $self = $class->SUPER::new(@args);
    my ($type) = $self->_rearrange([qw(DATATYPE)],@args);
    $type ||= 'linkset';
    $self->eutil('elink');
    $self->datatype($type);
    return $self;
}

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 @{$self->{'_sorted_id'}};
}

sub get_database {
    return ($_[0]->get_databases)[0];
}

sub get_db {
    return shift->get_database;
}

sub get_dbto {
    return shift->get_database;
}

sub get_databases {
    my $self = shift;
    my %tmp;
    my @dbs = sort map {$_->get_database} 
        grep {!$tmp{$_->get_database}++} ($self->get_LinkInfo);
    unshift @dbs, $self->{'_dbto'} if $self->{'_dbto'} && !$tmp{$self->{'_dbto'}}++;
    return @dbs;
}

sub get_dbs {
    return shift->get_databases;
}

sub get_dbfrom { return shift->{'_dbfrom'} }

sub get_link_names {
    my ($self) = shift;
    my %tmps;
    my @lns;
    if ($self->{'_linkname'}) {
        push @lns, $self->{'_linkname'};
        $tmps{$self->{'_linkname'}}++;
    }
    push @lns, map {$_->get_link_name} $self->get_LinkInfo;
    return @lns;
}

sub get_link_name {
    return ($_[0]->get_link_names)[0];
}

sub get_submitted_ids {
    my $self = shift;
    my $datatype = $self->datatype;
    if ($datatype eq 'idcheck' || $datatype eq 'urllink') {
        return $self->get_ids;
    } elsif ($self->{'_submitted_ids'}) {
        return @{$self->{'_submitted_ids'}};
    } else {
        return ();
    }
}

sub has_scores {
    my $self = shift;
    return exists $self->{'_has_scores'} ? 1 : 0;
}

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 %scores; 
}

sub get_score_by_id {
    my ($self, $id) = @_;
    ($id && exists $self->{'_id'}->{$id}) ? return $self->{'_id'}->{$id}->[1] :
        return;
}

sub has_linkout {
    my $self = shift;
    if (exists $self->{'_haslinkout'}) {
        return $self->{'_haslinkout'} eq 'Y' ? 1 : 0;
    } else  {
        return (grep {$_ eq 'LinkOut'} $self->get_databases) ? 1 : 0;
    } 
}

sub has_neighbor {
    my $self = shift;
    if (exists $self->{'_hasneighbor'}) {
        return $self->{'_hasneighbor'} eq 'Y' ? 1 : 0;
    } else {
        return 0;
    }
}

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'}->();
}

sub get_UrlLinks {
    my $self = shift;
    return ref $self->{'_urllinks'} ? @{ $self->{'_urllinks'} } : return;
}

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'}->();
}

sub get_LinkInfo {
    my $self = shift;
    return ref $self->{'_linkinfo'} ? @{ $self->{'_linkinfo'} } : return ();
}

{
    my %VALID_DATA = ('linkinfo' => 'linkinfo',
                      'linkinfos' => 'linkinfo',
                      'urllinks' => 'urllinks');
    
    sub rewind {
        my ($self, $arg) = @_;
        $arg ||= 'all';
        if (exists $VALID_DATA{$arg}) {
            delete $self->{'_'.$arg.'_it'};
        } elsif ($arg eq 'all') {
            delete $self->{'_'.$_.'_it'} for values %VALID_DATA;
        }
    }
}

# 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) = @_;
    if (exists $data->{IdList}->{Id}) {
        @{$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}}) {
        $urldata->{dbfrom} = $data->{DbFrom} if exists $data->{DbFrom};
        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}}) {
        $linkinfo->{dbfrom} = $data->{DbFrom} if exists $data->{DbFrom};
        my $obj = Bio::Tools::EUtilities::Info::LinkInfo->new(-eutil => 'elink',
                                                             -datatype => 'linkinfo',
                                                             -verbose => $self->verbose
                                                             );
        $obj->_add_data($linkinfo);
        push @{$self->{'_linkinfo'}}, $obj;
    }
}

sub to_string {
    my $self = shift;
    my $level = shift || 0;
    my $pad = 20 - $level;
    #        order     method                    name
    my %tags = (1 => ['get_databases'         => 'DB'],
                2 => ['get_ids'               => 'ID'],
                3 => ['get_link_names'        => 'Link Names'],
                5 => ['get_submitted_ids'     => 'Submitted IDs'],
                6 => ['has_scores'            => 'Scores?'],
                7 => ['has_linkout'           => 'LinkOut?'],
                8 => ['has_neighbor'          => 'DB Neighbors?'],
                9 => ['get_webenv'            => 'WebEnv'],
                10 => ['get_query_key'        => 'Key'],
                );
    my $string;
    for my $tag (sort {$a <=> $b} keys %tags) {
        my ($m, $nm) = (@{$tags{$tag}}[0..1]);
        # using this awkward little construct to deal with both lists and scalars
        my @content = grep {defined $_} $self->$m();
        next unless @content;
        $string .= $self->_text_wrap(
                 sprintf("%-*s%-*s:",$level, '',$pad, $nm,),
                 ' ' x ($pad).':',
                 join(', ',@content))."\n";
    }
    while (my $li = $self->next_LinkInfo) {
        $string .= $li->to_string(4);
    }
    while (my $ui = $self->next_UrlLink) {
        $string .= $ui->to_string(4);
    }
    if ($self->has_scores) {
        $string .= "Scores:\n";
        my %scores = $self->get_scores;
        $string .= sprintf("%-*s%-*s%s\n",
            $level + 4, '',
            $pad - 4, 'ID', 'Score'
            );        
        for my $id ($self->get_ids) {
            $string .= sprintf("%-*s%-*s%s\n",
                $level + 4, '',
                $pad - 4, $id, $scores{$id}
                );
        }
    }
    $string .= "\n";
    return $string;
}

1;