fix bugs to do with reading relationships

[scpubgit/stemmatology.git] / lib / Text / Tradition / Collation.pm

diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm
index 37efe67..1f4e00f 100644 (file)
--- a/lib/Text/Tradition/Collation.pm
+++ b/lib/Text/Tradition/Collation.pm
@@ -246,12 +246,12 @@ sub relationship_valid {
     # 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;
             }
@@ -313,7 +313,10 @@ sub as_dot {
     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",
@@ -367,7 +370,18 @@ sub as_graphml {
     $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;
@@ -412,6 +426,11 @@ sub as_graphml {
     $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;
@@ -540,6 +559,7 @@ sub _make_witness_row {
     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;
@@ -972,7 +992,13 @@ sub calculate_ranks {
     }
     # Transfer our rankings from the topological graph to the real one.
     foreach my $r ( $self->readings ) {
-        $r->rank( $node_ranks->{$rel_containers{$r->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?";
+        }
     }
 }
 
@@ -1262,3 +1288,13 @@ sub add_hash_entry {
 
 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