use Encode qw( decode_utf8 );
use File::Temp;
+use Graph;
use Graph::Easy;
use IPC::Run qw( run binary );
use Text::CSV_XS;
# The lists of 'in' and 'out' should not have any element that appears
# in 'proposed_related'.
foreach my $pr ( @proposed_related ) {
- foreach my $e ( $pr->incoming ) {
+ foreach my $e ( grep { $_->sub_class eq 'path' } $pr->incoming ) {
if( exists $pr_ids{ $e->from->name } ) {
return 0;
}
}
- foreach my $e ( $pr->outgoing ) {
+ foreach my $e ( grep { $_->sub_class eq 'path' } $pr->outgoing ) {
if( exists $pr_ids{ $e->to->name } ) {
return 0;
}
my( $self, $view ) = @_;
$view = 'path' unless $view;
# TODO consider making some of these things configurable
- my $dot = sprintf( "digraph %s {\n", $self->tradition->name );
+ my $graph_name = $self->tradition->name;
+ $graph_name =~ s/[^\w\s]//g;
+ $graph_name = join( '_', split( /\s+/, $graph_name ) );
+ my $dot = sprintf( "digraph %s {\n", $graph_name );
$dot .= "\tedge [ arrowhead=open ];\n";
$dot .= "\tgraph [ rankdir=LR ];\n";
$dot .= sprintf( "\tnode [ fontsize=%d, fillcolor=%s, style=%s, shape=%s ];\n",
$root->setNamespace( $xsi_ns, 'xsi', 0 );
$root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
- # TODO Add some global graph data
+ # Add the data keys for the graph
+ my %graph_data_keys;
+ my $gdi = 0;
+ my @graph_attributes = qw/ wit_list_separator baselabel linear ac_label /;
+ foreach my $datum ( @graph_attributes ) {
+ $graph_data_keys{$datum} = 'dg'.$gdi++;
+ my $key = $root->addNewChild( $graphml_ns, 'key' );
+ $key->setAttribute( 'attr.name', $datum );
+ $key->setAttribute( 'attr.type', $key eq 'linear' ? 'boolean' : 'string' );
+ $key->setAttribute( 'for', 'graph' );
+ $key->setAttribute( 'id', $graph_data_keys{$datum} );
+ }
# Add the data keys for nodes
my %node_data_keys;
# Add the data keys for edges, i.e. witnesses
my $edi = 0;
my %edge_data_keys;
- foreach my $edge_key( qw/ witness extra relationship class / ) {
+ my @string_keys = qw/ class witness relationship /;
+ my @bool_keys = qw/ extra equal_rank non_correctable non_independent /;
+ foreach my $edge_key( @string_keys ) {
$edge_data_keys{$edge_key} = 'de'.$edi++;
my $key = $root->addNewChild( $graphml_ns, 'key' );
$key->setAttribute( 'attr.name', $edge_key );
- $key->setAttribute( 'attr.type', $edge_key eq 'extra' ? 'boolean' : 'string' );
+ $key->setAttribute( 'attr.type', 'string' );
+ $key->setAttribute( 'for', 'edge' );
+ $key->setAttribute( 'id', $edge_data_keys{$edge_key} );
+ }
+ foreach my $edge_key( @bool_keys ) {
+ $edge_data_keys{$edge_key} = 'de'.$edi++;
+ my $key = $root->addNewChild( $graphml_ns, 'key' );
+ $key->setAttribute( 'attr.name', $edge_key );
+ $key->setAttribute( 'attr.type', 'boolean' );
$key->setAttribute( 'for', 'edge' );
$key->setAttribute( 'id', $edge_data_keys{$edge_key} );
}
$graph->setAttribute( 'parse.nodeids', 'canonical' );
$graph->setAttribute( 'parse.nodes', scalar($self->readings) );
$graph->setAttribute( 'parse.order', 'nodesfirst' );
+
+ # Collation attribute data
+ foreach my $datum ( @graph_attributes ) {
+ _add_graphml_data( $graph, $graph_data_keys{$datum}, $self->$datum );
+ }
my $node_ctr = 0;
my %node_hash;
}
_add_graphml_data( $edge_el, $edge_data_keys{'witness'}, $base );
} elsif( $e->sub_class eq 'relationship' ) {
- # It's a relationship, so save the relationship type
+ # It's a relationship, so save the relationship data
_add_graphml_data( $edge_el, $edge_data_keys{'relationship'}, $e->label );
+ _add_graphml_data( $edge_el, $edge_data_keys{'equal_rank'}, $e->equal_rank );
+ _add_graphml_data( $edge_el, $edge_data_keys{'non_correctable'}, $e->non_correctable );
+ _add_graphml_data( $edge_el, $edge_data_keys{'non_independent'}, $e->non_independent );
}
}
sub _add_graphml_data {
my( $el, $key, $value ) = @_;
- my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
return unless defined $value;
+ my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
$data_el->setAttribute( 'key', $key );
$data_el->appendText( $value );
}
foreach my $rdg ( @$path ) {
my $rtext = $rdg->text;
$rtext = '#LACUNA#' if $rdg->is_lacuna;
+ # print STDERR "No rank for " . $rdg->name . "\n" unless defined $rdg->rank;
$char_hash{$rdg->rank} = $noderefs ? $rdg : $rtext;
}
my @row = map { $char_hash{$_} } @$positions;
# Walk a version of the graph where every node linked by a relationship
# edge is fundamentally the same node, and do a topological ranking on
# the nodes in this graph.
- my $topo_graph = Graph::Easy->new();
+ my $topo_graph = Graph->new();
my %rel_containers;
my $rel_ctr = 0;
# Add the nodes
if( @rels ) {
# Make a relationship container.
push( @rels, $r );
- my $rn = $topo_graph->add_node( 'rel_container_' . $rel_ctr++ );
+ my $rn = 'rel_container_' . $rel_ctr++;
+ $topo_graph->add_vertex( $rn );
foreach( @rels ) {
$rel_containers{$_->name} = $rn;
}
} else {
# Add a new node to mirror the old node.
- $rel_containers{$r->name} = $topo_graph->add_node( $r->name );
+ $rel_containers{$r->name} = $r->name;
+ $topo_graph->add_vertex( $r->name );
}
}
# Add the edges. Need only one edge between any pair of nodes.
foreach my $r ( $self->readings ) {
foreach my $n ( $r->neighbor_readings( 'forward' ) ) {
- $topo_graph->add_edge_once( $rel_containers{$r->name},
- $rel_containers{$n->name} );
+ my( $tfrom, $tto ) = ( $rel_containers{$r->name},
+ $rel_containers{$n->name} );
+ $topo_graph->add_edge( $tfrom, $tto )
+ unless $topo_graph->has_edge( $tfrom, $tto );
}
}
# Now do the rankings, starting with the start node.
my $topo_start = $rel_containers{$self->start->name};
- my $node_ranks = { $topo_start->name => 0 };
+ my $node_ranks = { $topo_start => 0 };
my @curr_origin = ( $topo_start );
# A little iterative function.
while( @curr_origin ) {
- @curr_origin = _assign_rank( $node_ranks, @curr_origin );
+ @curr_origin = _assign_rank( $topo_graph, $node_ranks, @curr_origin );
}
# Transfer our rankings from the topological graph to the real one.
foreach my $r ( $self->readings ) {
- $r->rank( $node_ranks->{$rel_containers{$r->name}->name} );
+ if( defined $node_ranks->{$rel_containers{$r->name}} ) {
+ $r->rank( $node_ranks->{$rel_containers{$r->name}} );
+ } else {
+ $DB::single = 1;
+ die "No rank calculated for node " . $r->name
+ . " - do you have a cycle in the graph?";
+ }
}
}
sub _assign_rank {
- my( $node_ranks, @current_nodes ) = @_;
+ my( $graph, $node_ranks, @current_nodes ) = @_;
# Look at each of the children of @current_nodes. If all the child's
# parents have a rank, assign it the highest rank + 1 and add it to
- # @next_nodes. Otherwise skip it.
+ # @next_nodes. Otherwise skip it; we will return when the highest-ranked
+ # parent gets a rank.
my @next_nodes;
foreach my $c ( @current_nodes ) {
- warn "Current reading " . $c->name . "has no rank!"
- unless exists $node_ranks->{$c->name};
- # print STDERR "Looking at child of node " . $c->name . ", rank "
- # . $node_ranks->{$c->name} . "\n";
- my @children = map { $_->to } $c->outgoing;
- foreach my $child ( @children ) {
- next if exists $node_ranks->{$child->name};
+ warn "Current reading $c has no rank!"
+ unless exists $node_ranks->{$c};
+ # print STDERR "Looking at child of node $c, rank "
+ # . $node_ranks->{$c} . "\n";
+ foreach my $child ( $graph->successors( $c ) ) {
+ next if exists $node_ranks->{$child};
my $highest_rank = -1;
my $skip = 0;
- my @parents = map { $_->from } $child->incoming;
- foreach my $parent ( @parents ) {
- if( exists $node_ranks->{$parent->name} ) {
- $highest_rank = $node_ranks->{$parent->name}
- if $highest_rank <= $node_ranks->{$parent->name};
+ foreach my $parent ( $graph->predecessors( $child ) ) {
+ if( exists $node_ranks->{$parent} ) {
+ $highest_rank = $node_ranks->{$parent}
+ if $highest_rank <= $node_ranks->{$parent};
} else {
$skip = 1;
last;
}
}
next if $skip;
- # print STDERR "Assigning rank " . ( $highest_rank + 1 ) . " to node " . $child->name . "\n";
- $node_ranks->{$child->name} = $highest_rank + 1;
+ my $c_rank = $highest_rank + 1;
+ # print STDERR "Assigning rank $c_rank to node $child \n";
+ $node_ranks->{$child} = $c_rank;
push( @next_nodes, $child );
}
}
no Moose;
__PACKAGE__->meta->make_immutable;
+
+=head1 BUGS / TODO
+
+=over
+
+=item * Rationalize edge classes
+
+=item * Port the internal graph from Graph::Easy to Graph
+
+=back
projects / scpubgit/stemmatology.git / blobdiff