change analysis graph calculation - closer but not correct yet.

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

diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm
index e0c879a..d28d7d7 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",
@@ -525,14 +528,13 @@ sub as_csv {
 # in the table are the nodes or simply their readings.
 
 sub make_alignment_table {
-    my( $self, $noderefs ) = @_;
+    my( $self, $noderefs, $include ) = @_;
     unless( $self->linear ) {
         warn "Need a linear graph in order to make an alignment table";
         return;
     }
     my $table;
     my @all_pos = sort { $a <=> $b } $self->possible_positions;
-    $DB::single = 1;
     foreach my $wit ( $self->tradition->witnesses ) {
         # print STDERR "Making witness row(s) for " . $wit->sigil . "\n";
         my @row = _make_witness_row( $wit->path, \@all_pos, $noderefs );
@@ -545,8 +547,19 @@ sub make_alignment_table {
         }           
     }
 
+    if( $include ) {
+        my $winnowed = [];
+        # Winnow out the rows for any witness not included.
+        foreach my $row ( @$table ) {
+            next unless $include->{$row->[0]};
+            push( @$winnowed, $row );
+        }
+        $table = $winnowed;
+    }
+
     # Return a table where the witnesses read in columns rather than rows.
     my $turned = _turn_table( $table );
+    # TODO We should really go through and delete empty rows.
     return $turned;
 }
 
@@ -557,6 +570,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;
@@ -989,7 +1003,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?";
+        }
     }
 }
 
@@ -1279,3 +1299,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