File Coverage

blib/lib/Bio/Coordinate/Graph.pm

Criterion	Covered	Total	%
statement	82	88	93.1
branch	25	40	62.5
condition	3	3	100.0
subroutine	8	9	88.8
pod	5	5	100.0
total	123	145	84.8

package Bio::Coordinate::Graph;
our $AUTHORITY = 'cpan:BIOPERLML';
$Bio::Coordinate::Graph::VERSION = '1.007001';
use utf8;
use strict;
use warnings;
use parent qw(Bio::Root::Root);

# ABSTRACT: Finds shortest path between nodes in a graph.
# AUTHOR:   Heikki Lehvaslaiho
# OWNER:    Heikki Lehvaslaiho
# LICENSE:  Perl_5



sub new {
    my($class,@args) = @_;
    my $self = $class->SUPER::new(@args);

    my($graph, $hasharray) =
        $self->_rearrange([qw(
                              GRAPH
                              HASHARRAY
                             )],
                         @args);

    $graph  && $self->graph($graph);
    $hasharray  && $self->hasharray($hasharray);

    $self->{'_root'} = undef;

    return $self; # success - we hope!
}


sub graph {

  my ($self,$value) = @_;

  if ($value) {
      $self->throw("Need a hash of hashes")
          unless  ref($value) eq 'HASH' ;
      $self->{'_dag'} = $value;

      # empty the cache
      $self->{'_root'} = undef;

  }

  return $self->{'_dag'};

}


sub hash_of_arrays {

  my ($self,$value) = @_;

  # empty the cache
  $self->{'_root'} = undef;

  if ($value) {

      $self->throw("Need a hash of hashes")
          unless  ref($value) eq 'HASH' ;

      #copy the hash of arrays into a hash of hashes;
      my %hash;
      foreach my $start ( keys %{$value}){
          $hash{$start} = undef;
          map { $hash{$start}{$_} = 1 } @{$value->{$start}};
      }

      $self->{'_dag'} = \%hash;
  }

  return $self->{'_dag'};

}


sub shortest_path {
    my ($self, $root, $end) = @_;

    $self->throw("Two arguments needed") unless @_ == 3;
    $self->throw("No node name [$root]")
        unless exists $self->{'_dag'}->{$root};
    $self->throw("No node name [$end]")
        unless exists $self->{'_dag'}->{$end};

    my @res;     # results
    my $reverse;

    if ($root > $end) {
        ($root, $end) = ($end, $root );
        $reverse++;
    }

    # try to use cached paths
    $self->dijkstra($root) unless
        defined $self->{'_root'} and $self->{'_root'} eq $root;

    return @res unless $self->{'_paths'} ;

    # create the list
    my $node = $end;
    my $prev = $self->{'_paths'}->{$end}{'prev'};
    while ($prev) {
        unshift @res, $node;
        $node = $self->{'_paths'}->{$node}{'prev'};
        $prev = $self->{'_paths'}->{$node}{'prev'};
    }
    unshift @res, $node;

    $reverse ? return reverse @res : return @res;
}


sub dijkstra {
    my ($self,$root) = @_;

    $self->throw("I need the name of the root node input") unless $root;
    $self->throw("No node name [$root]")
        unless exists $self->{'_dag'}->{$root};

    my %est = ();          # estimate hash
    my %res = ();          # result hash
    my $nodes = keys %{$self->{'_dag'}};
    my $maxdist = 1000000;

    # cache the root value
    $self->{'_root'} = $root;

    foreach my $node ( keys %{$self->{'_dag'}} ){
        if ($node eq $root) {
            $est{$node}{'prev'} = undef;
            $est{$node}{'dist'} = 0;
        } else {
            $est{$node}{'prev'} = undef;
            $est{$node}{'dist'} = $maxdist;
        }
    }

    # remove nodes from %est until it is empty
    while (keys %est) {

        #select the node closest to current one, or root node
        my $min_node;
        my $min = $maxdist;
        foreach my $node (reverse sort keys %est) {
            if ( $est{$node}{'dist'} < $min ) {
                $min = $est{$node}{'dist'};
                $min_node = $node;
            }
        }

        # no more links between nodes
        last unless ($min_node);

        # move the node from %est into %res;
        $res{$min_node} = delete $est{$min_node};

        # recompute distances to the neighbours
        my $dist = $res{$min_node}{'dist'};
        foreach my $neighbour ( keys %{$self->{'_dag'}->{$min_node}} ){
            next unless $est{$neighbour}; # might not be there any more
            $est{$neighbour}{'prev'} = $min_node;
            $est{$neighbour}{'dist'} =
                $dist + $self->{'_dag'}{$min_node}{$neighbour}
                if $est{$neighbour}{'dist'} > $dist + 1 ;
        }
    }
    return $self->{'_paths'} = \%res;
}

1;

__END__