From: Tara L Andrews Date: Mon, 13 Feb 2012 13:25:19 +0000 (+0100) Subject: modify alignment table API, to allow table caching X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1dd07bda1ca984d1218473cf165da01c214d555f;p=scpubgit%2Fstemmatology.git modify alignment table API, to allow table caching --- diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm index 8f3d6d2..6297295 100644 --- a/lib/Text/Tradition/Collation.pm +++ b/lib/Text/Tradition/Collation.pm @@ -94,6 +94,13 @@ has 'cached_svg' => ( predicate => 'has_cached_svg', clearer => 'wipe_svg', ); + +has 'cached_table' => ( + is => 'rw', + isa => 'HashRef', + predicate => 'has_cached_table', + clearer => 'wipe_table', + ); =head1 NAME @@ -245,6 +252,12 @@ sub BUILD { ### 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' ) { @@ -257,6 +270,7 @@ sub add_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 ); @@ -273,6 +287,7 @@ around del_reading => sub { $arg = $arg->id; } # Remove the reading from the graphs. + $self->_clear_cache; $self->sequence->delete_vertex( $arg ); $self->relations->delete_reading( $arg ); @@ -288,6 +303,7 @@ sub merge_readings { # 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. @@ -343,6 +359,7 @@ sub add_path { # 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 @@ -363,6 +380,7 @@ sub del_path { # 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 ); } @@ -391,6 +409,7 @@ be called via $tradition->del_witness. 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 ) { @@ -413,6 +432,7 @@ sub add_relationship { $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; } @@ -687,7 +707,16 @@ sub _path_display_label { 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 @@ -892,7 +921,7 @@ row per witness (or witness uncorrected.) 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 @@ -901,14 +930,14 @@ sub as_csv { # 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: @@ -928,8 +957,11 @@ keys have a true hash value will be included. =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; @@ -943,22 +975,23 @@ sub make_alignment_table { } # 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; @@ -967,8 +1000,7 @@ sub _make_witness_row { $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 @@ -977,8 +1009,8 @@ sub _make_witness_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; @@ -986,30 +1018,6 @@ sub _make_witness_row { 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 ) @@ -1463,7 +1471,7 @@ is_deeply( \@marked, \@expected, "Found correct list of common readings" ); 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 %hash; diff --git a/t/stemma.t b/t/stemma.t index 45f1f3f..697d0d2 100644 --- a/t/stemma.t +++ b/t/stemma.t @@ -30,7 +30,7 @@ ok( $stemma->isa( 'Text::Tradition::Stemma' ), 'Got the right sort of object' ); is( $stemma->graph, '1-2,1-A,2-B,2-C', "Got the correct graph" ); # Test for character matrix creation -my $mstr = character_input( $c->make_alignment_table() ); +my $mstr = character_input( $c->alignment_table() ); ## check number of rows my @mlines = split( "\n", $mstr ); my $msig = shift @mlines;