use Encode qw( decode_utf8 );
use File::Temp;
+use File::Which;
use Graph;
use IPC::Run qw( run binary );
use Text::CSV_XS;
predicate => 'has_cached_svg',
clearer => 'wipe_svg',
);
+
+has 'cached_table' => (
+ is => 'rw',
+ isa => 'HashRef',
+ predicate => 'has_cached_table',
+ clearer => 'wipe_table',
+ );
=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->_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->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;
# 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;
# 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;
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;
# Clear the witness(es) out of the paths
foreach my $e ( $self->paths ) {
foreach my $sig ( @sigils ) {
$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;
return @vectors;
}
my $wits = $self->sequence->get_edge_attributes( @$e );
@all_witnesses{ keys %$wits } = 1;
}
+ my $acstr = $self->ac_label;
+ foreach my $acwit ( grep { $_ =~ s/^(.*)\Q$acstr\E$/$1/ } keys %all_witnesses ) {
+ delete $all_witnesses{$acwit.$acstr} if exists $all_witnesses{$acwit};
+ }
return keys %all_witnesses;
}
=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'};
if( !$self->has_cached_svg || $opts->{'recalc'} || $want_subgraph ) {
my @cmd = qw/dot -Tsvg/;
return join( ', ', @wits );
}
}
-
+
+=head2 witnesses_at_rank
+
+Returns a list of witnesses that are not lacunose, for a given rank.
+
+=cut
+
+sub witnesses_at_rank {
+ my( $self, $rank ) = @_;
+}
=head2 as_graphml
sub as_csv {
my( $self ) = @_;
- my $table = $self->make_alignment_table;
+ my $table = $self->alignment_table;
my $csv = Text::CSV_XS->new( { binary => 1, quote_null => 0 } );
my @result;
# Make the header row
# Make the rest of the rows
foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
- my @row = map { $_ ? $_->{'t'} : $_ } @rowobjs;
+ my @row = map { $_ ? $_->{'t'}->text : $_ } @rowobjs;
$csv->combine( @row );
push( @result, decode_utf8( $csv->string ) );
}
return join( "\n", @result );
}
-=head2 make_alignment_table( $use_refs, $include_witnesses )
+=head2 alignment_table( $use_refs, $include_witnesses )
Return a reference to an alignment table, in a slightly enhanced CollateX
format which looks like this:
=cut
-sub make_alignment_table {
- my( $self, $noderefs, $include ) = @_;
+sub alignment_table {
+ my( $self ) = @_;
+ my $include; # see if we can ditch this
+ return $self->cached_table if $self->has_cached_table;
+
# Make sure we can do this
throw( "Need a linear graph in order to make an alignment table" )
unless $self->linear;
}
# 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, $noderefs );
+ my @row = _make_witness_row( \@wit_path, \@all_pos );
push( @{$table->{'alignment'}},
{ 'witness' => $wit->sigil, 'tokens' => \@row } );
if( $wit->is_layered ) {
my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
$wit->sigil.$self->ac_label );
- my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos, $noderefs );
+ my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos );
push( @{$table->{'alignment'}},
{ 'witness' => $wit->sigil.$self->ac_label, 'tokens' => \@ac_row } );
}
}
- return $table;
+ $self->cached_table( $table );
+ return $table;
}
sub _make_witness_row {
- my( $path, $positions, $noderefs ) = @_;
+ my( $path, $positions ) = @_;
my %char_hash;
map { $char_hash{$_} = undef } @$positions;
my $debug = 0;
$rtext = '#LACUNA#' if $rdg->is_lacuna;
print STDERR "rank " . $rdg->rank . "\n" if $debug;
# print STDERR "No rank for " . $rdg->id . "\n" unless defined $rdg->rank;
- $char_hash{$rdg->rank} = $noderefs ? { 't' => $rdg }
- : { 't' => $rtext };
+ $char_hash{$rdg->rank} = { 't' => $rdg };
}
my @row = map { $char_hash{$_} } @$positions;
# Fill in lacuna markers for undef spots in the row
foreach my $el ( @row ) {
# If we are using node reference, make the lacuna node appear many times
# in the table. If not, use the lacuna tag.
- if( $last_el && _el_is_lacuna( $last_el ) && !defined $el ) {
- $el = $noderefs ? $last_el : { 't' => '#LACUNA#' };
+ if( $last_el && $last_el->{'t'}->is_lacuna && !defined $el ) {
+ $el = $last_el;
}
push( @filled_row, $el );
$last_el = $el;
return @filled_row;
}
-# Tiny utility function to say if a table element is a lacuna
-sub _el_is_lacuna {
- my $el = shift;
- return 1 if $el->{'t'} eq '#LACUNA#';
- return 1 if ref( $el->{'t'} ) eq 'Text::Tradition::Collation::Reading'
- && $el->{'t'}->is_lacuna;
- return 0;
-}
-
-# Helper to turn the witnesses along columns rather than rows. Assumes
-# equal-sized rows.
-sub _turn_table {
- my( $table ) = @_;
- my $result = [];
- return $result unless scalar @$table;
- my $nrows = scalar @{$table->[0]};
- foreach my $idx ( 0 .. $nrows - 1 ) {
- foreach my $wit ( 0 .. $#{$table} ) {
- $result->[$idx]->[$wit] = $table->[$wit]->[$idx];
- }
- }
- return $result;
-}
-
=head1 NAVIGATION METHODS
=head2 reading_sequence( $first, $last, $sigil, $backup )
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;
+ $self->_clear_cache;
last;
}
}
sub calculate_common_readings {
my $self = shift;
my @common;
- my $table = $self->make_alignment_table( 1 );
+ my $table = $self->alignment_table;
foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
- my @row = map { $_->{'tokens'}->[$idx]->{'t'} } @{$table->{'alignment'}};
+ my @row = map { $_->{'tokens'}->[$idx]
+ ? $_->{'tokens'}->[$idx]->{'t'} : '' }
+ @{$table->{'alignment'}};
my %hash;
foreach my $r ( @row ) {
if( $r ) {
projects / scpubgit/stemmatology.git / blobdiff