File Coverage

blib/lib/Graph/Weighted.pm

Criterion	Covered	Total	%
statement	92	108	85.1
branch	30	36	83.3
condition	19	25	76.0
subroutine	12	13	92.3
pod	6	6	100.0
total	159	188	84.5

package Graph::Weighted;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: A weighted graph implementation

our $VERSION = '0.9002';

use warnings;
use strict;

use parent qw( Graph );

use Carp qw( croak );

use constant WEIGHT => 'weight';


sub populate {
    my ($self, $data, $attr) = @_;

    # Set the default attribute.
    $attr ||= WEIGHT;

    # What type of data are we given?
    my $data_ref = ref $data;

    if ($data_ref eq 'ARRAY' || $data_ref eq 'Math::Matrix') {
        my $vertex = 0; # Initial vertex id.
        for my $neighbors (@$data) {
            $self->_from_array($vertex, $neighbors, $attr);
            $vertex++; # Move on to the next vertex...
        }
    }
    elsif ($data_ref eq 'Math::MatrixReal') {
        my $vertex = 0;
        for my $neighbors (@{ $data->[0] }) {
            $self->_from_array($vertex, $neighbors, $attr);
            $vertex++;
        }
    }
    elsif ($data_ref eq 'HASH') {
        for my $vertex (keys %$data) {
            for my $entry ( keys %{ $data->{$vertex} } ) {
                if ( $entry eq 'label' ) {
                    my $label = delete $data->{$vertex}{$entry};
                    $self->set_vertex_attribute($vertex, $entry, $label);
                }
            }
            $self->_from_hash(
                $vertex, $data->{$vertex}, $attr
            );
        }
    }
    else {
        croak "Unknown data type: $data\n";
    }
}

sub _from_array {
    my ($self, $vertex, $neighbors, $attr) = @_;

    # Initial vertex weight
    my $vertex_weight = 0;

    # Make nodes and edges.
    for my $n (0 .. @$neighbors - 1) {
        my $w = $neighbors->[$n]; # Weight of the edge to the neighbor.
        next unless $w; # TODO Skip zero weight nodes if requested?

        # Add a node-node edge to the graph.
        $self->add_edge($vertex, $n);

        $self->set_edge_attribute($vertex, $n, $attr, $w);

        # Tally the weight of the vertex.
        $vertex_weight += $w;
    }

    # Set the weight of the graph node.
    $self->set_vertex_attribute($vertex, $attr, $vertex_weight);
}

sub _from_hash {
    my ($self, $vertex, $neighbors, $attr) = @_;

    # Initial vertex weight
    my $vertex_weight = 0;

    # Handle terminal nodes.
    if (ref $neighbors) {
        # Make nodes and edges.
        for my $n (keys %$neighbors) {
            my $w = $neighbors->{$n}; # Weight of the edge to the neighbor.

            # Add a node-node edge to the graph.
            $self->add_edge($vertex, $n);

            $self->set_edge_attribute($vertex, $n, $attr, $w);

            # Tally the weight of the vertex.
            $vertex_weight += $w;
        }
    }
    else {
        $vertex_weight = $neighbors;
    }

    # Set the weight of the graph node.
    $self->set_vertex_attribute($vertex, $attr, $vertex_weight);
}


sub get_cost {
    my ($self, $v, $attr) = @_;
    croak 'ERROR: No vertex given to get_cost()' unless defined $v;

    # Default to weight.
    $attr ||= WEIGHT;

    # Return the edge attribute if given a list.
    return $self->get_edge_attribute(@$v, $attr) || 0 if ref $v eq 'ARRAY';

    # Return the vertex attribute if given a scalar.
    return $self->get_vertex_attribute($v, $attr) || 0;
}


sub vertex_span {
    my ($self, $attr) = @_;

    # Get the cost of each vertex
    my $mass = {};
    for my $vertex ( $self->vertices ) {
        $mass->{$vertex} = $self->get_cost($vertex, $attr);
    }

    # Find the smallest & biggest costs
    my ($smallest, $biggest);
    for my $vertex ( keys %$mass ) {
        my $current = $mass->{$vertex};
        if ( !defined $smallest || $smallest > $current ) {
            $smallest = $current;
        }
        if ( !defined $biggest || $biggest < $current ) {
            $biggest = $current;
        }
    }

    # Collect the lightest & heaviest vertices
    my ($lightest, $heaviest) = ([], []);
    for my $vertex ( keys %$mass ) {
        push @$lightest, $vertex if $mass->{$vertex} == $smallest;
        push @$heaviest, $vertex if $mass->{$vertex} == $biggest;
    }

    return $lightest, $heaviest;
}


sub edge_span {
    my ($self, $attr) = @_;

    # Get the cost of each edge
    my $mass = {};
    for my $edge ( $self->edges ) {
        $mass->{ $edge->[0] . '_' . $edge->[1] } = $self->get_cost($edge, $attr);
    }

    # Find the smallest & biggest costs
    my ($smallest, $biggest);
    for my $edge ( keys %$mass ) {
        my $current = $mass->{$edge};
        if ( !defined $smallest || $smallest > $current ) {
            $smallest = $current;
        }
        if ( !defined $biggest || $biggest < $current ) {
            $biggest = $current;
        }
    }

    # Collect the lightest & heaviest edges
    my ($lightest, $heaviest) = ([], []);
    for my $edge ( sort keys %$mass ) {
        my $arrayref = [ split /_/, $edge ];
        push @$lightest, $arrayref if $mass->{$edge} == $smallest;
        push @$heaviest, $arrayref if $mass->{$edge} == $biggest;
    }

    return $lightest, $heaviest;
}



sub path_cost {
    my ($self, $path, $attr) = @_;

    return unless $self->has_path( @$path );

    my $path_cost = 0;

    for my $i ( 0 .. @$path - 2 ) {
        $path_cost += $self->get_cost( [ $path->[$i], $path->[ $i + 1 ] ], $attr );
    }

    return $path_cost;
}


sub dump {
    my $self = shift;
    my $attr = shift || 'weight';

    for my $vertex ( sort { $a <=> $b } $self->vertices ) {
        my $label = $self->get_vertex_attribute($vertex, 'label');
        printf "%svertex: %s %s=%.2f\n",
            ( $label ? "$label " : '' ),
            $vertex,
            $attr,
            $self->get_cost( $vertex, $attr );
        for my $successor ( sort { $a <=> $b } $self->successors($vertex) ) {
            printf "\tedge to: %s %s=%.2f\n",
                $successor,
                $attr,
                $self->get_cost( [ $vertex, $successor ], $attr );
        }
    }
}

1;

__END__