get rid of erroneous double-decode

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

diff --git a/base/lib/Text/Tradition/Collation.pm b/base/lib/Text/Tradition/Collation.pm
index a47e3d1..ae36da5 100644 (file)
--- a/base/lib/Text/Tradition/Collation.pm
+++ b/base/lib/Text/Tradition/Collation.pm
@@ -476,7 +476,7 @@ is( scalar( $sc->readings ), $numr, "There are $numr readings in the graph" );
 is( $sc->end->rank, 14, "There are fourteen ranks in the graph" );
 
 # Detach the erroneously collated reading
-my $newr = $sc->duplicate_reading( 'n131', 'Ba96' );
+my( $newr, @del_rdgs ) = $sc->duplicate_reading( 'n131', 'Ba96' );
 ok( $newr, "New reading was created" );
 ok( $sc->reading('n131_0'), "Detached the bad collation with a new reading" );
 is( scalar( $sc->readings ), $numr + 1, "A reading was added to the graph" );
@@ -485,13 +485,17 @@ my $csucc = $sc->common_successor( 'n131', 'n131_0' );
 is( $csucc->id, 'n136', "Found correct common successor to duped reading" ); 
 
 # Check that the bad transposition is gone
+is( scalar @del_rdgs, 1, "Deleted reading was returned by API call" );
 is( $sc->get_relationship( 'n130', 'n135' ), undef, "Bad transposition relationship is gone" );
 
+# The collation should not be fixed
+my @pairs = $sc->identical_readings();
+is( scalar @pairs, 0, "Not re-collated yet" );
 # Fix the collation
 ok( $sc->merge_readings( 'n124', 'n131_0' ), "Collated the readings correctly" );
-my @pairs = $sc->identical_readings( start => 'n124', end => $csucc->id );
-is( $sc->end->rank, 11, "The ranks shifted appropriately" );
+@pairs = $sc->identical_readings( start => 'n124', end => $csucc->id );
 is( scalar @pairs, 3, "Found three more identical readings" );
+is( $sc->end->rank, 11, "The ranks shifted appropriately" );
 $sc->flatten_ranks();
 is( scalar( $sc->readings ), $numr - 3, "Now we are collated correctly" );
 
@@ -553,6 +557,7 @@ sub duplicate_reading {
        # remove them. If not, we can skip it.
        my $succ;
        my %rrk;
+       my @deleted_relations;
        if( $self->end->has_rank ) {
                # Find the point where we can stop checking
                $succ = $self->common_successor( $r, $newr );
@@ -573,11 +578,13 @@ sub duplicate_reading {
                        my @noncolo = $rdg->related_readings( sub { !$_[0]->colocated } );
                        next unless @noncolo;
                        foreach my $nc ( @noncolo ) {
-                               $self->relations->verify_or_delete( $rdg, $nc );
+                               unless( $self->relations->verify_or_delete( $rdg, $nc ) ) {
+                                       push( @deleted_relations, [ $rdg->id, $nc->id ] );
+                               }
                        }
                }
        }
-       return $newr;
+       return ( $newr, @deleted_relations );
 }
 
 sub _generate_dup_id {
@@ -696,8 +703,8 @@ around qw/ get_relationship del_relationship / => sub {
        if( @args == 1 && ref( $args[0] ) eq 'ARRAY' ) {
                @args = @{$_[0]};
        }
-       my( $source, $target ) = $self->_stringify_args( @args );
-       $self->$orig( $source, $target );
+       my @stringargs = $self->_stringify_args( @args );
+       $self->$orig( @stringargs );
 };
 
 =head2 reading_witnesses( $reading )
@@ -860,7 +867,8 @@ sub as_dot {
     foreach my $edge ( @edges ) {
        # Do we need to output this edge?
        if( $used{$edge->[0]} && $used{$edge->[1]} ) {
-               my $label = $self->_path_display_label( $self->path_witnesses( $edge ) );
+               my $label = $self->_path_display_label( $opts,
+                       $self->path_witnesses( $edge ) );
                        my $variables = { %edge_attrs, 'label' => $label };
                        
                        # Account for the rank gap if necessary
@@ -920,7 +928,8 @@ sub as_dot {
     
     # Add substitute start and end edges if necessary
     foreach my $node ( keys %substart ) {
-       my $witstr = $self->_path_display_label ( $self->path_witnesses( $substart{$node}, $node ) );
+       my $witstr = $self->_path_display_label( $opts, 
+               $self->path_witnesses( $substart{$node}, $node ) );
        my $variables = { %edge_attrs, 'label' => $witstr };
        my $nrdg = $self->reading( $node );
        if( $nrdg->has_rank && $nrdg->rank > $startrank ) {
@@ -931,7 +940,8 @@ sub as_dot {
         $dot .= "\t\"__SUBSTART__\" -> \"$node\" $varopts;\n";
        }
     foreach my $node ( keys %subend ) {
-       my $witstr = $self->_path_display_label ( $self->path_witnesses( $node, $subend{$node} ) );
+       my $witstr = $self->_path_display_label( $opts,
+               $self->path_witnesses( $node, $subend{$node} ) );
        my $variables = { %edge_attrs, 'label' => $witstr };
         my $varopts = _dot_attr_string( $variables );
         $dot .= "\t\"$node\" -> \"__SUBEND__\" $varopts;\n";
@@ -1004,6 +1014,7 @@ sub path_witnesses {
 # witnesses only where the main witness is not also in the list.
 sub _path_display_label {
        my $self = shift;
+       my $opts = shift;
        my %wits;
        map { $wits{$_} = 1 } @_;
 
@@ -1021,14 +1032,18 @@ sub _path_display_label {
                }
        }
        
-       # See if we are in a majority situation.
-       my $maj = scalar( $self->tradition->witnesses ) * 0.6;
-       $maj = $maj > 5 ? $maj : 5;
-       if( scalar keys %wits > $maj ) {
-               unshift( @disp_ac, 'majority' );
-               return join( ', ', @disp_ac );
-       } else {
+       if( $opts->{'explicit_wits'} ) {
                return join( ', ', sort keys %wits );
+       } else {
+               # See if we are in a majority situation.
+               my $maj = scalar( $self->tradition->witnesses ) * 0.6;
+               $maj = $maj > 5 ? $maj : 5;
+               if( scalar keys %wits > $maj ) {
+                       unshift( @disp_ac, 'majority' );
+                       return join( ', ', @disp_ac );
+               } else {
+                       return join( ', ', sort keys %wits );
+               }
        }
 }
 
@@ -1383,13 +1398,13 @@ sub as_csv {
     my @result;
     # Make the header row
     $csv->combine( map { $_->{'witness'} } @{$table->{'alignment'}} );
-       push( @result, decode_utf8( $csv->string ) );
+       push( @result, $csv->string );
     # Make the rest of the rows
     foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
        my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
        my @row = map { $_ ? $_->{'t'}->text : $_ } @rowobjs;
         $csv->combine( @row );
-        push( @result, decode_utf8( $csv->string ) );
+        push( @result, $csv->string );
     }
     return join( "\n", @result );
 }
@@ -1816,7 +1831,6 @@ graph, specified either by node or by rank.
 sub identical_readings {
        my ( $self, %args ) = @_;
     # Find where we should start and end.
-    $DB::single = 1;
     my $startrank = $args{startrank} || 0;
     if( $args{start} ) {
        throw( "Starting reading has no rank" ) unless $self->reading( $args{start} )