use Encode qw( decode_utf8 );
use File::Temp;
+use File::Which;
use Graph;
use IPC::Run qw( run binary );
use Text::CSV_XS;
handles => {
relationships => 'relationships',
related_readings => 'related_readings',
+ get_relationship => 'get_relationship',
del_relationship => 'del_relationship',
},
writer => '_set_relations',
predicate => 'has_cached_table',
clearer => 'wipe_table',
);
+
+has '_graphcalc_done' => (
+ is => 'rw',
+ isa => 'Bool',
+ default => undef,
+ );
=head1 NAME
### Reading construct/destruct functions
-sub _clear_cache {
- my $self = shift;
- $self->wipe_svg if $self->has_cached_svg;
- $self->wipe_table if $self->has_cached_table;
-}
-
sub add_reading {
my( $self, $reading ) = @_;
unless( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
if( $self->reading( $reading->id ) ) {
throw( "Collation already has a reading with id " . $reading->id );
}
- $self->_clear_cache;
+ $self->_graphcalc_done(0);
$self->_add_reading( $reading->id => $reading );
# Once the reading has been added, put it in both graphs.
$self->sequence->add_vertex( $reading->id );
$arg = $arg->id;
}
# Remove the reading from the graphs.
- $self->_clear_cache;
+ $self->_graphcalc_done(0);
$self->sequence->delete_vertex( $arg );
$self->relations->delete_reading( $arg );
# We only need the IDs for adding paths to the graph, not the reading
# objects themselves.
my( $kept, $deleted, $combine_char ) = $self->_stringify_args( @_ );
- $self->_clear_cache;
+ $self->_graphcalc_done(0);
# The kept reading should inherit the paths and the relationships
# of the deleted reading.
# objects themselves.
my( $source, $target, $wit ) = $self->_stringify_args( @_ );
- $self->_clear_cache;
+ $self->_graphcalc_done(0);
# Connect the readings
$self->sequence->add_edge( $source, $target );
# Note the witness in question
# objects themselves.
my( $source, $target, $wit ) = $self->_stringify_args( @args );
- $self->_clear_cache;
+ $self->_graphcalc_done(0);
if( $self->sequence->has_edge_attribute( $source, $target, $wit ) ) {
$self->sequence->delete_edge_attribute( $source, $target, $wit );
}
sub clear_witness {
my( $self, @sigils ) = @_;
- $self->_clear_cache;
+ $self->_graphcalc_done(0);
# Clear the witness(es) out of the paths
foreach my $e ( $self->paths ) {
foreach my $sig ( @sigils ) {
my( $source, $target, $opts ) = $self->_stringify_args( @_ );
my( @vectors ) = $self->relations->add_relationship( $source,
$self->reading( $source ), $target, $self->reading( $target ), $opts );
- # Force a full rank recalculation every time. Yuck.
- $self->calculate_ranks() if $self->end->has_rank;
- $self->_clear_cache;
+ $self->_graphcalc_done(0);
return @vectors;
}
+around qw/ get_relationship del_relationship / => sub {
+ my $orig = shift;
+ my $self = shift;
+ my @args = @_;
+ if( @args == 1 && ref( $args[0] ) eq 'ARRAY' ) {
+ @args = @{$_[0]};
+ }
+ my( $source, $target ) = $self->_stringify_args( @args );
+ $self->$orig( $source, $target );
+};
+
=head2 reading_witnesses( $reading )
Return a list of sigils corresponding to the witnesses in which the reading appears.
=head2 as_svg( \%options )
Returns an SVG string that represents the graph, via as_dot and graphviz.
-See as_dot for a list of options.
+See as_dot for a list of options. Must have GraphViz (dot) installed to run.
=cut
sub as_svg {
my( $self, $opts ) = @_;
+ throw( "Need GraphViz installed to output SVG" )
+ unless File::Which::which( 'dot' );
my $want_subgraph = exists $opts->{'from'} || exists $opts->{'to'};
+ $self->calculate_ranks() unless $self->_graphcalc_done;
if( !$self->has_cached_svg || $opts->{'recalc'} || $want_subgraph ) {
my @cmd = qw/dot -Tsvg/;
my( $svg, $err );
next if $reading->id eq $reading->text;
my $rattrs;
my $label = $reading->text;
+ $label .= '-' if $reading->join_next;
+ $label = "-$label" if $reading->join_prior;
$label =~ s/\"/\\\"/g;
$rattrs->{'label'} = $label;
$rattrs->{'fillcolor'} = '#b3f36d' if $reading->is_common && $color_common;
sub as_graphml {
my( $self ) = @_;
-
+ $self->calculate_ranks unless $self->_graphcalc_done;
+
# Some namespaces
my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
is_start => 'boolean',
is_end => 'boolean',
is_lacuna => 'boolean',
+ is_common => 'boolean',
+ join_prior => 'boolean',
+ join_next => 'boolean',
);
foreach my $datum ( keys %node_data ) {
$node_data_keys{$datum} = 'dn'.$ndi++;
relationship => 'string', # ID/label for a relationship
extra => 'boolean', # Path key
scope => 'string', # Relationship key
+ annotation => 'string', # Relationship key
non_correctable => 'boolean', # Relationship key
non_independent => 'boolean', # Relationship key
);
sub alignment_table {
my( $self ) = @_;
- my $include; # see if we can ditch this
+ $self->calculate_ranks() unless $self->_graphcalc_done;
return $self->cached_table if $self->has_cached_table;
# Make sure we can do this
my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
my @all_pos = ( 1 .. $self->end->rank - 1 );
foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
- if( $include ) {
- next unless $include->{$wit->sigil};
- }
# print STDERR "Making witness row(s) for " . $wit->sigil . "\n";
my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
my @row = _make_witness_row( \@wit_path, \@all_pos );
$start = $self->start unless $start;
$end = $self->end unless $end;
my @path = grep { !$_->is_meta } $self->reading_sequence( $start, $end, $wit );
- return join( ' ', map { $_->text } @path );
+ my $pathtext = '';
+ my $last;
+ foreach my $r ( @path ) {
+ if( $r->join_prior || !$last || $last->join_next ) {
+ $pathtext .= $r->text;
+ } else {
+ $pathtext .= ' ' . $r->text;
+ }
+ $last = $r;
+ }
+ return $pathtext;
}
=head1 INITIALIZATION METHODS
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" );
+my $table = $c->alignment_table;
+ok( $c->has_cached_table, "Alignment table was cached" );
+is( $c->alignment_table, $table, "Cached table returned upon second call" );
$c->calculate_ranks;
-is( $c->as_svg, $svg, "Cached SVG retained with no rank change" );
+is( $c->alignment_table, $table, "Cached table retained with no rank change" );
$c->add_relationship( 'n9', 'n23', { 'type' => 'spelling' } );
-isnt( $c->as_svg, $svg, "SVG changed after relationship add" );
+isnt( $c->alignment_table, $table, "Alignment table changed after relationship add" );
=end testing
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 ) {
+ # Do we need to invalidate the cached data?
+ if( $self->has_cached_svg || $self->has_cached_table ) {
foreach my $r ( $self->readings ) {
- next if $existing_ranks{$r} == $r->rank;
- $self->wipe_svg;
+ next if defined( $existing_ranks{$r} )
+ && $existing_ranks{$r} == $r->rank;
+ # Something has changed, so clear the cache
+ $self->_clear_cache;
+ # ...and recalculate the common readings.
+ $self->calculate_common_readings();
last;
}
}
+ # The graph calculation information is now up to date.
+ $self->_graphcalc_done(1);
}
sub _assign_rank {
return @next_nodes;
}
+sub _clear_cache {
+ my $self = shift;
+ $self->wipe_svg if $self->has_cached_svg;
+ $self->wipe_table if $self->has_cached_table;
+}
+
+
=head2 flatten_ranks
A convenience method for parsing collation data. Searches the graph for readings
}
}
}
-
-=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
sub calculate_common_readings {
my $self = shift;
my @common;
+ map { $_->is_common( 0 ) } $self->readings;
+ # Implicitly calls calculate_ranks
my $table = $self->alignment_table;
foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
my @row = map { $_->{'tokens'}->[$idx]
projects / scpubgit/stemmatology.git / blobdiff