From: tla Date: Wed, 25 May 2011 08:56:04 +0000 (+0200) Subject: add expand/collapse path edge functionality X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1f563ac315e46e9e05f82b7c803e35d8a4a2fe14;p=scpubgit%2Fstemmatology.git add expand/collapse path edge functionality --- diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm index d211a02..ea194ef 100644 --- a/lib/Text/Tradition/Collation.pm +++ b/lib/Text/Tradition/Collation.pm @@ -68,6 +68,12 @@ has 'baselabel' => ( default => 'base text', ); +has 'collapsed' => ( + is => 'rw', + isa => 'Bool', + ); + + # The collation can be created two ways: # 1. Collate a set of witnesses (with CollateX I guess) and process # the results as in 2. @@ -148,6 +154,7 @@ sub as_svg { my( $self, $recalc ) = @_; return $self->svg if $self->has_svg; + $self->collapse_graph_edges(); $self->_save_graphviz( $self->graph->as_graphviz() ) unless( $self->has_graphviz && !$recalc ); @@ -156,6 +163,7 @@ sub as_svg { my $in = $self->graphviz; run( \@cmd, \$in, ">", binary(), \$svg ); $self->{'svg'} = $svg; + $self->expand_graph_edges(); return $svg; } @@ -200,7 +208,7 @@ sub as_graphml { # Add the data keys for edges my %wit_hash; my $wit_ctr = 0; - foreach my $wit ( $self->getWitnessList ) { + foreach my $wit ( @{$self->tradition->witnesses} ) { my $wit_key = 'w' . $wit_ctr++; $wit_hash{$wit} = $wit_key; my $key = $root->addNewChild( $graphml_ns, 'key' ); @@ -211,6 +219,7 @@ sub as_graphml { } # Add the graph, its nodes, and its edges + $self->collapse_graph_edges(); my $graph = $root->addNewChild( $graphml_ns, 'graph' ); $graph->setAttribute( 'edgedefault', 'directed' ); $graph->setAttribute( 'id', 'g0' ); # TODO make this meaningful @@ -246,7 +255,7 @@ sub as_graphml { } } - foreach my $e ( $self->edges() ) { + foreach my $e ( $self->paths() ) { my( $name, $from, $to ) = ( $e->name, $node_hash{ $e->from()->name() }, $node_hash{ $e->to()->name() } ); @@ -259,9 +268,86 @@ sub as_graphml { # Return the thing $self->_save_graphml( $graphml ); + $self->expand_graph_edges(); return $graphml; } +sub collapse_graph_edges { + my $self = shift; + # Our collation graph has an edge per witness. This is great for + # calculation purposes, but terrible for display. Thus we want to + # display only one edge between any two nodes. + + return if $self->collapsed; + + print STDERR "Collapsing path edges in graph...\n"; + + # Don't list out every witness if we have more than half to list. + my $majority = int( scalar( @{$self->tradition->witnesses} ) / 2 ) + 1; + foreach my $node( $self->readings ) { + my $newlabels = {}; + # We will visit each node, so we only look ahead. + foreach my $edge ( $node->outgoing() ) { + add_hash_entry( $newlabels, $edge->to->name, $edge->name ); + $self->del_path( $edge ); + } + + foreach my $newdest ( keys %$newlabels ) { + my $label; + my @compressed_wits = (); + if( @{$newlabels->{$newdest}} < $majority ) { + $label = join( ', ', @{$newlabels->{$newdest}} ); + } else { + ## TODO FIX THIS HACK + my @pclabels; + foreach my $wit ( @{$newlabels->{$newdest}} ) { + if( $wit =~ /^(.*?)(\s*\(?p\.\s*c\.\)?)$/ ) { + push( @pclabels, $wit ); + } else { + push( @compressed_wits, $wit ); + } + } + $label = join( ', ', 'majority', @pclabels ); + } + + my $newedge = + $self->add_path( $node, $self->reading( $newdest ), $label ); + if( @compressed_wits ) { + ## TODO fix this hack too. + $newedge->set_attribute( 'class', + join( '|', @compressed_wits ) ); + } + } + } + + $self->collapsed( 1 ); +} + +sub expand_graph_edges { + my $self = shift; + # Our collation graph has only one edge between any two nodes. + # This is great for display, but not so great for analysis. + # Expand this so that each witness has its own edge between any + # two reading nodes. + return unless $self->collapsed; + + print STDERR "Expanding path edges in graph...\n"; + + foreach my $edge( $self->paths ) { + my $from = $edge->from; + my $to = $edge->to; + my @wits = split( /, /, $edge->label ); + if( grep { $_ eq 'majority' } @wits ) { + push( @wits, split( /\|/, $edge->get_attribute( 'class' ) ) ); + } + $self->del_path( $edge ); + foreach ( @wits ) { + $self->add_path( $from, $to, $_ ); + } + } + $self->collapsed( 0 ); +} + =back =head2 Navigation methods @@ -479,11 +565,11 @@ sub walk_and_expand_base { my @common_readings; foreach my $wit ( @{$self->tradition->witnesses} ) { my $sig = $wit->sigil; + $DB::single = 1 if $sig eq 'Vb5'; my $post_sig; $post_sig = $wit->post_correctione if $wit->has_post_correctione; - # $DB::single = 1 if $wit->sigil eq 'Vb11'; my @wit_path = $self->reading_sequence( $self->start, $end, $sig ); $wit->path( \@wit_path ); $self->connect_readings_for_witness( $wit ); @@ -504,7 +590,6 @@ sub walk_and_expand_base { my $diverged = 0; my $last_common; my @correction; - $DB::single = 1 if $sig eq 'Vb12'; foreach my $rdg ( @corr_wit_path ) { if( exists( $in_orig{$rdg->name} ) && !$diverged ) { # We are reading the same here @@ -832,5 +917,14 @@ sub unique_list { return values( %h ); } +sub add_hash_entry { + my( $hash, $key, $entry ) = @_; + if( exists $hash->{$key} ) { + push( @{$hash->{$key}}, $entry ); + } else { + $hash->{$key} = [ $entry ]; + } +} + no Moose; __PACKAGE__->meta->make_immutable; diff --git a/lib/Text/Tradition/Parser/BaseText.pm b/lib/Text/Tradition/Parser/BaseText.pm index 1849928..b530520 100644 --- a/lib/Text/Tradition/Parser/BaseText.pm +++ b/lib/Text/Tradition/Parser/BaseText.pm @@ -75,7 +75,7 @@ underscore in its name. =cut -my $SHORT = 20; + my $SHORT = 25; sub merge_base { my( $collation, $base_file, @app_entries ) = @_; @@ -250,7 +250,7 @@ sub merge_base { # Now walk paths and calculate positions. my @common_readings = - $collation->walk_and_expand_base( $collation->reading( '#END#' ) ); + $collation->walk_and_expand_base( $collation->reading( '#END#' ) ); $collation->calculate_positions( @common_readings ); } diff --git a/script/svg_from_csv.pl b/script/svg_from_csv.pl index 40fa7f5..3a27521 100644 --- a/script/svg_from_csv.pl +++ b/script/svg_from_csv.pl @@ -5,10 +5,10 @@ use strict; use warnings; use Text::Tradition; -my $collation_graph = Text::Tradition->new( - 'CSV' => $ARGV[0], - 'base' => $ARGV[1], - ); +my $tradition = Text::Tradition->new( + 'CSV' => $ARGV[0], + 'base' => $ARGV[1], + ); -print $collation_graph->as_svg(); +print $tradition->collation->as_svg(); print STDERR "Done\n";