From: Tara L Andrews Date: Sun, 12 Feb 2012 23:09:56 +0000 (+0100) Subject: Merge branch 'master' of github.com:tla/stemmatology X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9317e522bb0299ab6bdcfe2d999750719e893407;hp=-c;p=scpubgit%2Fstemmatology.git Merge branch 'master' of github.com:tla/stemmatology --- 9317e522bb0299ab6bdcfe2d999750719e893407 diff --combined lib/Text/Tradition/Collation.pm index cc197ff,8f3d6d2..2b5dbeb --- a/lib/Text/Tradition/Collation.pm +++ b/lib/Text/Tradition/Collation.pm @@@ -27,7 -27,6 +27,7 @@@ has 'relations' => handles => { relationships => 'relationships', related_readings => 'related_readings', + del_relationship => 'del_relationship', }, writer => '_set_relations', ); @@@ -88,6 -87,13 +88,13 @@@ has 'end' => writer => '_set_end', weak_ref => 1, ); + + has 'cached_svg' => ( + is => 'rw', + isa => 'Str', + predicate => 'has_cached_svg', + clearer => 'wipe_svg', + ); =head1 NAME @@@ -442,17 -448,23 +449,23 @@@ See as_dot for a list of options sub as_svg { my( $self, $opts ) = @_; - - my @cmd = qw/dot -Tsvg/; - my( $svg, $err ); - my $dotfile = File::Temp->new(); - ## USE FOR DEBUGGING - # $dotfile->unlink_on_destroy(0); - binmode $dotfile, ':utf8'; - print $dotfile $self->as_dot( $opts ); - push( @cmd, $dotfile->filename ); - run( \@cmd, ">", binary(), \$svg ); - return decode_utf8( $svg ); + my $want_subgraph = exists $opts->{'from'} || exists $opts->{'to'}; + if( !$self->has_cached_svg || $opts->{'recalc'} || $want_subgraph ) { + my @cmd = qw/dot -Tsvg/; + my( $svg, $err ); + my $dotfile = File::Temp->new(); + ## USE FOR DEBUGGING + # $dotfile->unlink_on_destroy(0); + binmode $dotfile, ':utf8'; + print $dotfile $self->as_dot( $opts ); + push( @cmd, $dotfile->filename ); + run( \@cmd, ">", binary(), \$svg ); + $svg = decode_utf8( $svg ); + $self->cached_svg( $svg ) unless $want_subgraph; + return $svg; + } else { + return $self->cached_svg; + } } @@@ -478,7 -490,9 +491,9 @@@ sub as_dot my $startrank = $opts->{'from'} if $opts; my $endrank = $opts->{'to'} if $opts; my $color_common = $opts->{'color_common'} if $opts; - + my $STRAIGHTENHACK = !$startrank && !$endrank && $self->end->rank + && $self->end->rank > 100; + # Check the arguments if( $startrank ) { return if $endrank && $startrank > $endrank; @@@ -489,7 -503,6 +504,6 @@@ $endrank = undef if $endrank == $self->end->rank; } - # TODO consider making some of these things configurable my $graph_name = $self->tradition->name; $graph_name =~ s/[^\w\s]//g; $graph_name = join( '_', split( /\s+/, $graph_name ) ); @@@ -521,12 -534,17 +535,17 @@@ if( $endrank ) { $dot .= "\t\"#SUBEND#\" [ label=\"...\" ];\n"; } - + if( $STRAIGHTENHACK ) { + ## HACK part 1 + $dot .= "\tsubgraph { rank=same \"#START#\" \"#SILENT#\" }\n"; + $dot .= "\t\"#SILENT#\" [ shape=diamond,color=white,penwidth=0,label=\"\" ];" + } my %used; # Keep track of the readings that actually appear in the graph # Sort the readings by rank if we have ranks; this speeds layout. my @all_readings = $self->end->has_rank ? sort { $a->rank <=> $b->rank } $self->readings : $self->readings; + # TODO Refrain from outputting lacuna nodes - just grey out the edges. foreach my $reading ( @all_readings ) { # Only output readings within our rank range. next if $startrank && $reading->rank < $startrank; @@@ -544,7 -562,7 +563,7 @@@ # Add the real edges. Need to weight one edge per rank jump, in a # continuous line. - my $weighted = $self->_add_edge_weights; + # my $weighted = $self->_add_edge_weights; my @edges = $self->paths; my( %substart, %subend ); foreach my $edge ( @edges ) { @@@ -563,11 -581,11 +582,11 @@@ } # Add the calculated edge weights - if( exists $weighted->{$edge->[0]} - && $weighted->{$edge->[0]} eq $edge->[1] ) { - # $variables->{'color'} = 'red'; - $variables->{'weight'} = 3.0; - } + # if( exists $weighted->{$edge->[0]} + # && $weighted->{$edge->[0]} eq $edge->[1] ) { + # # $variables->{'color'} = 'red'; + # $variables->{'weight'} = 3.0; + # } # EXPERIMENTAL: make edge width reflect no. of witnesses my $extrawidth = scalar( $self->path_witnesses( $edge ) ) * 0.2; @@@ -595,6 -613,10 +614,10 @@@ my $varopts = _dot_attr_string( $variables ); $dot .= "\t\"$node\" -> \"#SUBEND#\" $varopts;"; } + # HACK part 2 + if( $STRAIGHTENHACK ) { + $dot .= "\t\"#END#\" -> \"#SILENT#\" [ color=white,penwidth=0 ];\n"; + } $dot .= "}\n"; return $dot; @@@ -616,13 -638,18 +639,18 @@@ sub _add_edge_weights # the largest number of witness paths each time. my $weighted = {}; my $curr = $self->start->id; + my $ranked = $self->end->has_rank; while( $curr ne $self->end->id ) { + my $rank = $ranked ? $self->reading( $curr )->rank : 0; my @succ = sort { $self->path_witnesses( $curr, $a ) <=> $self->path_witnesses( $curr, $b ) } $self->sequence->successors( $curr ); my $next = pop @succ; + my $nextrank = $ranked ? $self->reading( $next )->rank : 0; # Try to avoid lacunae in the weighted path. - while( $self->reading( $next )->is_lacuna && @succ ) { + while( @succ && + ( $self->reading( $next )->is_lacuna || + $nextrank - $rank > 1 ) ){ $next = pop @succ; } $weighted->{$curr} = $next; @@@ -1209,10 -1236,36 +1237,36 @@@ sub make_witness_path Calculate the reading ranks (that is, their aligned positions relative to each other) for the graph. This can only be called on linear collations. + =begin testing + + use Text::Tradition; + + my $cxfile = 't/data/Collatex-16.xml'; + my $t = Text::Tradition->new( + 'name' => 'inline', + 'input' => 'CollateX', + 'file' => $cxfile, + ); + my $c = $t->collation; + + # Make an svg + my $svg = $c->as_svg; + is( substr( $svg, 0, 5 ), 'has_cached_svg, "SVG was cached" ); + is( $c->as_svg, $svg, "Cached SVG returned upon second call" ); + $c->calculate_ranks; + is( $c->as_svg, $svg, "Cached SVG retained with no rank change" ); + $c->add_relationship( 'n9', 'n23', { 'type' => 'spelling' } ); + isnt( $c->as_svg, $svg, "SVG changed after relationship add" ); + + =end testing + =cut sub calculate_ranks { my $self = shift; + # Save the existing ranks, in case we need to invalidate the cached SVG. + my %existing_ranks; # 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. @@@ -1240,6 -1293,7 +1294,7 @@@ # Add the edges. foreach my $r ( $self->readings ) { + $existing_ranks{$r} = $r->rank; foreach my $n ( $self->sequence->successors( $r->id ) ) { my( $tfrom, $tto ) = ( $rel_containers{$r->id}, $rel_containers{$n} ); @@@ -1269,6 -1323,14 +1324,14 @@@ throw( "Ranks not calculated after $last - do you have a cycle in the graph?" ); } } + # Do we need to invalidate the cached SVG? + if( $self->has_cached_svg ) { + foreach my $r ( $self->readings ) { + next if $existing_ranks{$r} == $r->rank; + $self->wipe_svg; + last; + } + } } sub _assign_rank { @@@ -1330,6 -1392,45 +1393,45 @@@ sub flatten_ranks } } + =head2 remove_collations + + Another convenience method for parsing. Removes all 'collation' relationships + that were defined in order to get the reading ranks to be correct. + + =begin testing + + use Text::Tradition; + + my $cxfile = 't/data/Collatex-16.xml'; + my $t = Text::Tradition->new( + 'name' => 'inline', + 'input' => 'CollateX', + 'file' => $cxfile, + ); + my $c = $t->collation; + + isnt( $c->reading('n23')->rank, $c->reading('n9')->rank, "Rank skew exists" ); + $c->add_relationship( 'n23', 'n9', { 'type' => 'collated', 'scope' => 'local' } ); + is( scalar $c->relationships, 4, "Found all expected relationships" ); + $c->remove_collations; + is( scalar $c->relationships, 3, "Collated relationships now gone" ); + is( $c->reading('n23')->rank, $c->reading('n9')->rank, "Aligned ranks were preserved" ); + + =end testing + + =cut + + sub remove_collations { + my $self = shift; + foreach my $reledge ( $self->relationships ) { + my $relobj = $self->relations->get_relationship( $reledge ); + if( $relobj && $relobj->type eq 'collated' ) { + $self->relations->delete_relationship( $reledge ); + } + } + } + + =head2 calculate_common_readings Goes through the graph identifying the readings that appear in every witness diff --combined lib/Text/Tradition/Collation/RelationshipStore.pm index 9e9b718,b5e2e53..334b5fe --- a/lib/Text/Tradition/Collation/RelationshipStore.pm +++ b/lib/Text/Tradition/Collation/RelationshipStore.pm @@@ -23,38 -23,9 +23,38 @@@ general) between readings =begin testing use Text::Tradition; +use TryCatch; use_ok( 'Text::Tradition::Collation::RelationshipStore' ); +# Add some relationships, and delete them + +my $cxfile = 't/data/Collatex-16.xml'; +my $t = Text::Tradition->new( + 'name' => 'inline', + 'input' => 'CollateX', + 'file' => $cxfile, + ); +my $c = $t->collation; + +my @v1 = $c->add_relationship( 'n21', 'n22', { 'type' => 'meaning' } ); +is( scalar @v1, 1, "Added a single relationship" ); +is( $v1[0]->[0], 'n21', "Got correct node 1" ); +is( $v1[0]->[1], 'n22', "Got correct node 2" ); +my @v2 = $c->add_relationship( 'n9', 'n23', + { 'type' => 'spelling', 'scope' => 'global' } ); +is( scalar @v2, 2, "Added a global relationship with two instances" ); +@v1 = $c->del_relationship( 'n22', 'n21' ); +is( scalar @v1, 1, "Deleted first relationship" ); +@v2 = $c->del_relationship( 'n8', 'n13' ); +is( scalar @v2, 2, "Deleted second global relationship" ); +try { + my @v3 = $c->del_relationship( 'n1', 'n2' ); + ok( 0, "Should have errored on non-existent relationship" ); +} catch( Text::Tradition::Error $e ) { + like( $e->message, qr/No relationship defined/, "Attempt to delete non-existent relationship errored" ); +} + =end testing =head1 METHODS @@@ -86,9 -57,24 +86,24 @@@ has 'graph' => relationships => 'edges', add_reading => 'add_vertex', delete_reading => 'delete_vertex', + delete_relationship => 'delete_edge', }, ); + around 'delete_relationship' => sub { + my $orig = shift; + my $self = shift; + my @vector; + if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) { + # Dereference the edge arrayref that was passed. + my $edge = shift; + @vector = @$edge; + } else { + @vector = @_; + } + return $self->$orig( @vector ); + }; + =head2 get_relationship Return the relationship object, if any, that exists between two readings. @@@ -96,7 -82,15 +111,15 @@@ =cut sub get_relationship { - my( $self, @vector ) = @_; + my $self = shift; + my @vector; + if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) { + # Dereference the edge arrayref that was passed. + my $edge = shift; + @vector = @$edge; + } else { + @vector = @_; + } my $relationship; if( $self->graph->has_edge_attribute( @vector, 'object' ) ) { $relationship = $self->graph->get_edge_attribute( @vector, 'object' ); @@@ -259,31 -253,6 +282,31 @@@ sub add_relationship return @pairs_set; } +=head2 del_relationship( $source, $target ) + +Removes the relationship between the given readings. If the relationship is +non-local, removes the relationship everywhere in the graph. + +=cut + +sub del_relationship { + my( $self, $source, $target ) = @_; + my $rel = $self->get_relationship( $source, $target ); + throw( "No relationship defined between $source and $target" ) unless $rel; + my @vectors = ( [ $source, $target ] ); + $self->_remove_relationship( $source, $target ); + if( $rel->nonlocal ) { + # Remove the relationship wherever it occurs. + my @rel_edges = grep { $self->get_relationship( @$_ ) == $rel } + $self->relationships; + foreach my $re ( @rel_edges ) { + $self->_remove_relationship( @$re ); + push( @vectors, $re ); + } + } + return @vectors; +} + =head2 relationship_valid( $source, $target, $type ) Checks whether a relationship of type $type may exist between the readings given @@@ -298,6 -267,7 +321,7 @@@ sub relationship_valid if ( $rel eq 'transposition' || $rel eq 'repetition' ) { # Check that the two readings do (for a repetition) or do not (for # a transposition) appear in the same witness. + # TODO this might be called before witness paths are set... my %seen_wits; map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source ); foreach my $w ( $c->reading_witnesses( $target ) ) { @@@ -313,7 -283,9 +337,9 @@@ # Check that linking the source and target in a relationship won't lead # to a path loop for any witness. If they have the same rank then fine. return( 1, "ok" ) - if $c->reading( $source )->rank == $c->reading( $target )->rank; + if $c->reading( $source )->has_rank + && $c->reading( $target )->has_rank + && $c->reading( $source )->rank == $c->reading( $target )->rank; # Otherwise, first make a lookup table of all the # readings related to either the source or the target.