handles => {
relationships => 'relationships',
related_readings => 'related_readings',
+ del_relationship => 'del_relationship',
},
writer => '_set_relations',
);
writer => '_set_end',
weak_ref => 1,
);
+
+ has 'cached_svg' => (
+ is => 'rw',
+ isa => 'Str',
+ predicate => 'has_cached_svg',
+ clearer => 'wipe_svg',
+ );
=head1 NAME
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;
+ }
}
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;
$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 ) );
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;
# 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 ) {
}
# 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;
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;
# 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;
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 ), '<?xml', "Got XML doc for svg" );
+ ok( $c->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.
# 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} );
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 {
}
}
+ =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
=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
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.
=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' );
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
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 ) ) {
# 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.
projects / scpubgit/stemmatology.git / commitdiff