File Coverage

blib/lib/Graph/Easy/Weighted.pm
Criterion Covered Total %
statement 79 100 79.0
branch 25 36 69.4
condition 17 25 68.0
subroutine 11 12 91.6
pod 5 5 100.0
total 137 178 76.9


line stmt bran cond sub pod time code
1             package Graph::Easy::Weighted;
2             our $AUTHORITY = 'cpan:GENE';
3              
4             # ABSTRACT: A weighted graph implementation
5              
6             our $VERSION = '0.06';
7              
8 2     2   1936 use warnings;
  2         3  
  2         83  
9 2     2   9 use strict;
  2         4  
  2         56  
10              
11 2     2   1494 use parent qw(Graph::Easy);
  2         669  
  2         15  
12              
13 2     2   261003 use Carp qw( croak );
  2         5  
  2         145  
14 2     2   1910 use Readonly;
  2         6295  
  2         2560  
15             Readonly my $WEIGHT => 'weight';
16              
17              
18             sub populate {
19 6     6 1 6920 my ($self, $data, $attr, $format) = @_;
20              
21             # Set the default attribute.
22 6   33     35 $attr ||= $WEIGHT;
23              
24             # What type of data are we given?
25 6         46 my $data_ref = ref $data;
26              
27 6 50 33     23 if ($data_ref eq 'ARRAY' || $data_ref eq 'Math::Matrix') {
    0          
    0          
28 6         16 my $vertex = 0;
29 6         15 for my $neighbors (@$data) {
30 14         38 $self->_from_array( $vertex, $neighbors, $attr, $format );
31 14         1115 $vertex++;
32             }
33             }
34             elsif ($data_ref eq 'Math::MatrixReal') {
35 0         0 my $vertex = 0;
36 0         0 for my $neighbors (@{ $data->[0] }) {
  0         0  
37 0         0 $self->_from_array( $vertex, $neighbors, $attr, $format );
38 0         0 $vertex++;
39             }
40             }
41             elsif ($data_ref eq 'HASH') {
42 0         0 for my $vertex (keys %$data) {
43 0 0       0 if ( $data->{$vertex}{attributes} ) {
44 0         0 my $attributes = delete $data->{$vertex}{attributes};
45 0         0 for my $attr ( keys %$attributes ) {
46 0         0 $self->set_vertex_attribute($vertex, $attr, $attributes->{$attr});
47             }
48             }
49 0         0 $self->_from_hash( $vertex, $data->{$vertex}, $attr, $format );
50             }
51             }
52             else {
53 0         0 croak "Unknown data type: $data\n";
54             }
55             }
56              
57             sub _from_array {
58 14     14   20 my ($self, $vertex, $neighbors, $attr, $format) = @_;
59              
60 14         23 my $vertex_weight = 0;
61              
62 14         33 for my $n (0 .. @$neighbors - 1) {
63 55         84 my $w = $neighbors->[$n]; # Weight of the edge to the neighbor.
64 55 100       126 next unless $w;
65              
66 16         66 my $edge = Graph::Easy::Edge->new();
67 16 50       329 $edge->set_attributes(
68             {
69             label => $format ? sprintf( $format, $w ) : $w,
70             "x-$attr" => $w,
71             }
72             );
73              
74 16         1278 $self->add_edge($vertex, $n, $edge);
75              
76 16         1029 $vertex_weight += $w;
77             }
78              
79 14         57 $self->set_vertex_attribute($vertex, "x-$attr", $vertex_weight);
80             }
81              
82             sub _from_hash {
83 0     0   0 my ($self, $vertex, $neighbors, $attr, $format) = @_;
84              
85 0         0 my $vertex_weight = 0;
86              
87 0         0 for my $n (keys %$neighbors) {
88 0         0 my $w = $neighbors->{$n}; # Weight of the edge to the neighbor.
89              
90 0         0 my $edge = Graph::Easy::Edge->new();
91 0 0       0 $edge->set_attributes(
92             {
93             label => $format ? sprintf( $format, $w ) : $w,
94             "x-$attr" => $w,
95             }
96             );
97              
98 0         0 $self->add_edge($vertex, $n, $edge);
99              
100 0         0 $vertex_weight += $w;
101             }
102              
103 0         0 $self->set_vertex_attribute($vertex, "x-$attr", $vertex_weight);
104             }
105              
106              
107             sub get_cost {
108 36     36 1 4621 my ($self, $v, $attr) = @_;
109 36 50       87 croak 'ERROR: No vertex given to get_cost()' unless defined $v;
110              
111 36   66     100 $attr ||= $WEIGHT;
112              
113 36 100       175 if ( ref $v eq 'Graph::Easy::Edge' ) {
114 22   50     70 return $v->get_custom_attributes->{"x-$attr"} || 0;
115             }
116              
117 14   100     42 return $self->get_vertex_attribute($v->name, "x-$attr") || 0;
118             }
119              
120              
121             sub vertex_span {
122 1     1 1 5 my ($self, $attr) = @_;
123              
124 1         2 my $mass = {};
125 1         5 for my $vertex ( $self->vertices ) {
126 5         306 $mass->{$vertex->name} = $self->get_cost($vertex, $attr);
127             }
128              
129 1         73 my ($smallest, $biggest);
130 1         3 for my $vertex ( keys %$mass ) {
131 5         10 my $current = $mass->{$vertex};
132 5 100 100     31 if ( !defined $smallest || $smallest > $current ) {
133 3         6 $smallest = $current;
134             }
135 5 100 66     24 if ( !defined $biggest || $biggest < $current ) {
136 1         3 $biggest = $current;
137             }
138             }
139              
140 1         3 my ($lightest, $heaviest) = ([], []);
141 1         3 for my $vertex ( keys %$mass ) {
142 5 100       14 push @$lightest, $vertex if $mass->{$vertex} == $smallest;
143 5 100       16 push @$heaviest, $vertex if $mass->{$vertex} == $biggest;
144             }
145              
146 1         29 return $lightest, $heaviest;
147             }
148              
149              
150             sub edge_span {
151 1     1 1 992 my ($self, $attr) = @_;
152              
153 1         2 my $mass = {};
154 1         5 for my $edge ( $self->edges ) {
155 7         201 $mass->{ $edge->from->name . '_' . $edge->to->name } = $self->get_cost($edge, $attr);
156             }
157              
158 1         29 my ($smallest, $biggest);
159 1         4 for my $edge ( keys %$mass ) {
160 7         10 my $current = $mass->{$edge};
161 7 100 100     30 if ( !defined $smallest || $smallest > $current ) {
162 2         3 $smallest = $current;
163             }
164 7 100 66     34 if ( !defined $biggest || $biggest < $current ) {
165 1         3 $biggest = $current;
166             }
167             }
168              
169 1         3 my ($lightest, $heaviest) = ([], []);
170 1         5 for my $edge ( sort keys %$mass ) {
171 7         18 my $arrayref = [ split /_/, $edge ];
172 7 100       23 push @$lightest, $arrayref if $mass->{$edge} == $smallest;
173 7 100       20 push @$heaviest, $arrayref if $mass->{$edge} == $biggest;
174             }
175              
176 1         6 return $lightest, $heaviest;
177             }
178              
179              
180              
181             sub path_cost {
182 4     4 1 3547 my ($self, $path, $attr) = @_;
183              
184 4         6 my $path_cost = 0;
185              
186 4         12 for my $i ( 0 .. @$path - 2 ) {
187 7         78 my $edge = $self->edge( $path->[$i], $path->[ $i + 1 ] );
188 7 100       265 next unless $edge;
189 6         14 $path_cost += $self->get_cost( $edge, $attr );
190             }
191              
192 4         56 return $path_cost;
193             }
194              
195             1;
196              
197             __END__