use LWP::UserAgent;
use Text::Tradition;
use Text::Tradition::Stemma;
+use TryCatch;
use vars qw/ @EXPORT_OK /;
@EXPORT_OK = qw/ run_analysis group_variants analyze_variant_location wit_stringify /;
unless( exists $expected_genealogical{$row->{'id'}} ) {
$expected_genealogical{$row->{'id'}} = 1;
}
- is( $row->{'genealogical'}, $expected_genealogical{$row->{'id'}},
+ my $gen_bool = $row->{'genealogical'} ? 1 : 0;
+ is( $gen_bool, $expected_genealogical{$row->{'id'}},
"Got correct genealogical flag for row " . $row->{'id'} );
# Check that we have the right row with the right groups
my $rank = $row->{'id'};
my @groups;
my @use_ranks;
my %lacunae;
+ my $moved = {};
foreach my $rank ( @ranks ) {
my $missing = [ @lacunose ];
- my $rankgroup = group_variants( $tradition, $rank, $missing, \@collapse );
+ my $rankgroup = group_variants( $tradition, $rank, $missing, $moved, \@collapse );
+ # Filter out any empty rankgroups
+ # (e.g. from the later rank for a transposition)
+ next unless keys %$rankgroup;
if( $opts{'exclude_type1'} ) {
# Check to see whether this is a "useful" group.
my( $rdgs, $grps ) = _useful_variant( $rankgroup,
foreach my $idx ( 0 .. $#use_ranks ) {
my $location = $answer->{'variants'}->[$idx];
# Add the rank back in
- $location->{'id'} = $use_ranks[$idx];
+ my $rank = $use_ranks[$idx];
+ $location->{'id'} = $rank;
# Note what our lacunae are
my %lmiss;
map { $lmiss{$_} = 1 } @{$lacunae{$use_ranks[$idx]}};
- # Run through the reading groups and add as 'lacunae' any redundant
- # a.c. witnesses (yes, we have to do this before the analysis, thus
- # identical loops before and after. Boo.)
- # TODO Consider making these callbacks to analyze_location
- foreach my $rdghash ( @{$location->{'readings'}} ) {
- my %rwits;
- map { $rwits{$_} = 1 } @{$rdghash->{'group'}};
- foreach my $rw ( keys %rwits ) {
- if( $rw =~ /^(.*)\Q$aclabel\E$/ ) {
- if( exists $rwits{$1} ) {
- $lmiss{$rw} = 1;
- delete $rwits{$rw};
- }
- }
- }
- $rdghash->{'group'} = [ keys %rwits ];
- }
$location->{'missing'} = [ keys %lmiss ];
# Run the extra analysis we need.
- analyze_location( $tradition, $stemma->graph, $location );
+ analyze_location( $tradition, $stemma, $location, \%lmiss );
+ my @layerwits;
# Do the final post-analysis tidying up of the data.
foreach my $rdghash ( @{$location->{'readings'}} ) {
$conflict_count++
if exists $rdghash->{'conflict'} && $rdghash->{'conflict'};
- # Add the reading text back in
+ # Add the reading text back in, setting display value as needed
my $rdg = $c->reading( $rdghash->{'readingid'} );
- $rdghash->{'text'} = $rdg ? $rdg->text : $rdghash->{'readingid'};
+ if( $rdg ) {
+ $rdghash->{'text'} = $rdg->text .
+ ( $rdg->rank == $rank ? '' : ' [' . $rdg->rank . ']' );
+ }
# Remove lacunose witnesses from this reading's list now that the
# analysis is done
my @realgroup;
map { push( @realgroup, $_ ) unless $lmiss{$_} } @{$rdghash->{'group'}};
$rdghash->{'group'} = \@realgroup;
- # TODO Record hypotheticals used to create group, if we end up
- # needing it
+ # Note any layered witnesses that appear in this group
+ foreach( @realgroup ) {
+ if( $_ =~ /^(.*)\Q$aclabel\E$/ ) {
+ push( @layerwits, $1 );
+ }
+ }
}
+ $location->{'layerwits'} = \@layerwits if @layerwits;
}
$answer->{'conflict_count'} = $conflict_count;
Groups the variants at the given $rank of the collation, treating any
relationships in @merge_relationship_types as equivalent. $lacunose should
be a reference to an array, to which the sigla of lacunose witnesses at this
-rank will be appended.
+rank will be appended; $transposed should be a reference to a hash, wherein
+the identities of transposed readings and their relatives will be stored.
Returns a hash $group_readings where $rdg is attested by the witnesses listed
in $group_readings->{$rdg}.
# Return group_readings, groups, lacunose
sub group_variants {
- my( $tradition, $rank, $lacunose, $collapse ) = @_;
+ my( $tradition, $rank, $lacunose, $transposed, $collapse ) = @_;
my $c = $tradition->collation;
my $aclabel = $c->ac_label;
-
+ my $table = $c->alignment_table;
# Get the alignment table readings
my %readings_at_rank;
- my %is_lacunose; # lookup table for $lacunose
- map { $is_lacunose{$_} = 1 } @$lacunose;
- my @gap_wits;
- foreach my $tablewit ( @{$c->alignment_table->{'alignment'}} ) {
+ my %is_lacunose; # lookup table for witnesses not in stemma
+ map { $is_lacunose{$_} = 1; $is_lacunose{$_.$aclabel} = 1 } @$lacunose;
+ my @check_for_gaps;
+ my %moved_wits;
+ my $has_transposition;
+ foreach my $tablewit ( @{$table->{'alignment'}} ) {
my $rdg = $tablewit->{'tokens'}->[$rank-1];
my $wit = $tablewit->{'witness'};
# Exclude the witness if it is "lacunose" which if we got here
# means "not in the stemma".
next if $is_lacunose{$wit};
+ # Note if the witness is actually in a lacuna
if( $rdg && $rdg->{'t'}->is_lacuna ) {
_add_to_witlist( $wit, $lacunose, $aclabel );
+ # Otherwise the witness either has a positive reading...
} elsif( $rdg ) {
- $readings_at_rank{$rdg->{'t'}->text} = $rdg->{'t'};
+ # If the reading has been counted elsewhere as a transposition, ignore it.
+ if( $transposed->{$rdg->{'t'}->id} ) {
+ # TODO Does this cope with three-way transpositions?
+ map { $moved_wits{$_} = 1 } @{$transposed->{$rdg->{'t'}->id}};
+ next;
+ }
+ # Otherwise, record it...
+ $readings_at_rank{$rdg->{'t'}->id} = $rdg->{'t'};
+ # ...and grab any transpositions, and their relations.
+ my @transp = grep { $_->rank != $rank } $rdg->{'t'}->related_readings();
+ foreach my $trdg ( @transp ) {
+ next if exists $readings_at_rank{$trdg->id};
+ $has_transposition = 1;
+ my @affected_wits = _table_witnesses(
+ $table, $trdg, \%is_lacunose, $aclabel );
+ next unless @affected_wits;
+ map { $moved_wits{$_} = 1 } @affected_wits;
+ $transposed->{$trdg->id} =
+ [ _table_witnesses( $table, $rdg->{'t'}, \%is_lacunose, $aclabel ) ];
+ $readings_at_rank{$trdg->id} = $trdg;
+ }
+ # ...or it is empty, ergo a gap.
} else {
- _add_to_witlist( $wit, \@gap_wits, $aclabel );
+ _add_to_witlist( $wit, \@check_for_gaps, $aclabel );
}
}
-
+ my @gap_wits;
+ map { _add_to_witlist( $_, \@gap_wits, $aclabel )
+ unless $moved_wits{$_} } @check_for_gaps;
# Group the readings, collapsing groups by relationship if needed
- my %grouped_readings;
+ my $grouped_readings = {};
foreach my $rdg ( values %readings_at_rank ) {
# Skip readings that have been collapsed into others.
- next if exists $grouped_readings{$rdg->id} && !$grouped_readings{$rdg->id};
+ next if exists $grouped_readings->{$rdg->id}
+ && $grouped_readings->{$rdg->id} eq 'COLLAPSE';
# Get the witness list, including from readings collapsed into this one.
- my @wits = $rdg->witnesses;
- if( $collapse ) {
+ my @wits = _table_witnesses( $table, $rdg, \%is_lacunose, $aclabel );
+ if( $collapse && @$collapse ) {
my $filter = sub { my $r = $_[0]; grep { $_ eq $r->type } @$collapse; };
foreach my $other ( $rdg->related_readings( $filter ) ) {
- my @otherwits = $other->witnesses;
+ my @otherwits = _table_witnesses(
+ $table, $other, \%is_lacunose, $aclabel );
push( @wits, @otherwits );
- $grouped_readings{$other->id} = 0;
+ $grouped_readings->{$other->id} = 'COLLAPSE';
}
}
- # Filter the group to those witnesses in the stemma
- my @use_wits;
- foreach my $wit ( @wits ) {
- next if $is_lacunose{$wit};
- push( @use_wits, $wit );
- }
- $grouped_readings{$rdg->id} = \@use_wits;
+ $grouped_readings->{$rdg->id} = \@wits;
}
- $grouped_readings{'(omitted)'} = \@gap_wits if @gap_wits;
+ $grouped_readings->{'(omitted)'} = \@gap_wits if @gap_wits;
# Get rid of our collapsed readings
- map { delete $grouped_readings{$_} unless $grouped_readings{$_} }
- keys %grouped_readings
+ map { delete $grouped_readings->{$_} if $grouped_readings->{$_} eq 'COLLAPSE' }
+ keys %$grouped_readings
if $collapse;
+
+ # If something was transposed, check the groups for doubled-up readings
+ if( $has_transposition ) {
+ # print STDERR "Group for rank $rank:\n";
+ # map { print STDERR "\t$_: " . join( ' ' , @{$grouped_readings->{$_}} ) . "\n" }
+ # keys %$grouped_readings;
+ _check_transposed_consistency( $c, $rank, $transposed, $grouped_readings );
+ }
# Return the result
- return \%grouped_readings;
+ return $grouped_readings;
+}
+
+# Helper function to query the alignment table for all witnesses (a.c. included)
+# that have a given reading at its rank.
+sub _table_witnesses {
+ my( $table, $trdg, $lacunose, $aclabel ) = @_;
+ my $tableidx = $trdg->rank - 1;
+ my @has_reading;
+ foreach my $row ( @{$table->{'alignment'}} ) {
+ my $wit = $row->{'witness'};
+ next if $lacunose->{$wit};
+ my $rdg = $row->{'tokens'}->[$tableidx];
+ next unless exists $rdg->{'t'} && defined $rdg->{'t'};
+ _add_to_witlist( $wit, \@has_reading, $aclabel )
+ if $rdg->{'t'}->id eq $trdg->id;
+ }
+ return @has_reading;
}
# Helper function to ensure that X and X a.c. never appear in the same list.
}
}
+sub _check_transposed_consistency {
+ my( $c, $rank, $transposed, $groupings ) = @_;
+ my %seen_wits;
+ my %thisrank;
+ # Note which readings are actually at this rank, and which witnesses
+ # belong to which reading.
+ foreach my $rdg ( keys %$groupings ) {
+ my $rdgobj = $c->reading( $rdg );
+ # Count '(omitted)' as a reading at this rank
+ $thisrank{$rdg} = 1 if !$rdgobj || $rdgobj->rank == $rank;
+ map { push( @{$seen_wits{$_}}, $rdg ) } @{$groupings->{$rdg}};
+ }
+ # Our work is done if we have no witness belonging to more than one
+ # reading.
+ my @doubled = grep { scalar @{$seen_wits{$_}} > 1 } keys %seen_wits;
+ return unless @doubled;
+ # If we have a symmetric related transposition, drop the non-rank readings.
+ if( @doubled == scalar keys %seen_wits ) {
+ foreach my $rdg ( keys %$groupings ) {
+ if( !$thisrank{$rdg} ) {
+ my $groupstr = wit_stringify( $groupings->{$rdg} );
+ my ( $matched ) = grep { $groupstr eq wit_stringify( $groupings->{$_} ) }
+ keys %thisrank;
+ delete $groupings->{$rdg};
+ # If we found a group match, assume there is a symmetry happening.
+ # TODO think more about this
+ # print STDERR "*** Deleting symmetric reading $rdg\n";
+ unless( $matched ) {
+ delete $transposed->{$rdg};
+ warn "Found problem in evident symmetry with reading $rdg";
+ }
+ }
+ }
+ # Otherwise 'unhook' the transposed reading(s) that have duplicates.
+ } else {
+ foreach my $dup ( @doubled ) {
+ foreach my $rdg ( @{$seen_wits{$dup}} ) {
+ next if $thisrank{$rdg};
+ next unless exists $groupings->{$rdg};
+ # print STDERR "*** Deleting asymmetric doubled-up reading $rdg\n";
+ delete $groupings->{$rdg};
+ delete $transposed->{$rdg};
+ }
+ }
+ # and put any now-orphaned readings into an 'omitted' reading.
+ foreach my $wit ( keys %seen_wits ) {
+ unless( grep { exists $groupings->{$_} } @{$seen_wits{$wit}} ) {
+ $groupings->{'(omitted)'} = [] unless exists $groupings->{'(omitted)'};
+ _add_to_witlist( $wit, $groupings->{'(omitted)'}, $c->ac_label );
+ }
+ }
+ }
+}
+
=head2 solve_variants( $graph, @groups )
Sends the set of groups to the external graph solver service and returns
# Finally, add the group to the list to be calculated for this graph.
map { s/\Q$aclabel\E$// } @acwits;
- my $graph = $stemma->extend_graph( \@acwits );
+ my $graph;
+ try {
+ $graph = $stemma->extend_graph( \@acwits );
+ } catch {
+ die "Unable to extend graph with @acwits";
+ }
unless( exists $graph_problems->{"$graph"} ) {
$graph_problems->{"$graph"} = { 'object' => $graph, 'groups' => [] };
}
}
## For each distinct graph, send its groups to the solver.
- $DB::single = 1;
my $solver_url = 'http://byzantini.st/cgi-bin/graphcalc.cgi';
my $ua = LWP::UserAgent->new();
## Witness map is a HACK to get around limitations in node names from IDP
my $json = encode_json( _safe_wit_strings( $graph, $stemma->collation,
$groupings, $witness_map ) );
# Send it off and get the result
+ #print STDERR "Sending request: $json\n";
my $resp = $ua->post( $solver_url, 'Content-Type' => 'application/json',
'Content' => $json );
my $answer;
=cut
sub analyze_location {
- my ( $tradition, $graph, $variant_row ) = @_;
+ my ( $tradition, $stemma, $variant_row, $lacunose ) = @_;
+ my $c = $tradition->collation;
# Make a hash of all known node memberships, and make the subgraphs.
my $contig = {};
my $reading_roots = {};
my $subgraph = {};
+ my $acstr = $c->ac_label;
+ my @acwits;
+ $DB::single = 1 if $variant_row->{id} == 87;
+ # Note which witnesses positively belong to which group
foreach my $rdghash ( @{$variant_row->{'readings'}} ) {
my $rid = $rdghash->{'readingid'};
- map { $contig->{$_} = $rid } @{$rdghash->{'group'}};
-
+ foreach my $wit ( @{$rdghash->{'group'}} ) {
+ $contig->{$wit} = $rid;
+ if( $wit =~ /^(.*)\Q$acstr\E$/ ) {
+ push( @acwits, $1 );
+ }
+ }
+ }
+
+ # Get the actual graph we should work with
+ my $graph;
+ try {
+ $graph = @acwits ? $stemma->extend_graph( \@acwits ) : $stemma->graph;
+ } catch {
+ die "Could not extend graph with a.c. witnesses @acwits";
+ }
+
+ # Now, armed with that knowledge, make a subgraph for each reading
+ # and note the root(s) of each subgraph.
+ foreach my $rdghash( @{$variant_row->{'readings'}} ) {
+ my $rid = $rdghash->{'readingid'};
+ my %rdgwits;
# Make the subgraph.
my $part = $graph->copy;
- my %these_vertices;
- map { $these_vertices{$_} = 1 } @{$rdghash->{'group'}};
- $part->delete_vertices( grep { !$these_vertices{$_} } $part->vertices );
+ my @todelete = grep { exists $contig->{$_} && $contig->{$_} ne $rid }
+ keys %$contig;
+ $part->delete_vertices( @todelete );
+ _prune_subtree( $part, $lacunose );
$subgraph->{$rid} = $part;
+ # Record the remaining lacunose nodes as part of this group, if
+ # we are dealing with a non-genealogical reading.
+ unless( $variant_row->{'genealogical'} ) {
+ map { $contig->{$_} = $rid } $part->vertices;
+ }
# Get the reading roots.
map { $reading_roots->{$_} = $rid } $part->predecessorless_vertices;
}
# non-followed/unknown values for each reading. Also figure out the
# reading's evident parent(s).
foreach my $rdghash ( @{$variant_row->{'readings'}} ) {
- # Group string key - TODO do we need this?
- my $gst = wit_stringify( $rdghash->{'group'} );
my $rid = $rdghash->{'readingid'};
# Get the subgraph
my $part = $subgraph->{$rid};
# Start figuring things out.
- my @roots = $part->predecessorless_vertices;
- $rdghash->{'independent_occurrence'} = scalar @roots;
+ my @roots = grep { $reading_roots->{$_} eq $rid } keys %$reading_roots;
+ $rdghash->{'independent_occurrence'} = \@roots;
$rdghash->{'followed'} = scalar( $part->vertices ) - scalar( @roots );
# Find the parent readings, if any, of this reading.
- my %rdgparents;
+ my $rdgparents = {};
foreach my $wit ( @roots ) {
# Look in the main stemma to find this witness's extant or known-reading
# immediate ancestor(s), and look up the reading that each ancestor olds.
foreach my $wparent( @check ) {
my $preading = $contig->{$wparent};
if( $preading ) {
- $rdgparents{$preading} = 1;
+ $rdgparents->{$preading} = 1;
} else {
push( @next, $graph->predecessors( $wparent ) );
}
@check = @next;
}
}
- $rdghash->{'reading_parents'} = [ keys %rdgparents ];
+ foreach my $p ( keys %$rdgparents ) {
+ # Resolve the relationship of the parent to the reading, and
+ # save it in our hash.
+ my $pobj = $c->reading( $p );
+ my $relation;
+ my $prep = $pobj ? $pobj->id . ' (' . $pobj->text . ')' : $p;
+ if( $pobj ) {
+ my $rel = $c->get_relationship( $p, $rdghash->{readingid} );
+ if( $rel ) {
+ $relation = { type => $rel->type };
+ if( $rel->has_annotation ) {
+ $relation->{'annotation'} = $rel->annotation;
+ }
+ }
+ }
+ $rdgparents->{$p} = { 'label' => $prep, 'relation' => $relation };
+ }
+
+ $rdghash->{'reading_parents'} = $rdgparents;
# Find the number of times this reading was altered, and the number of
# times we're not sure.
# that implicitly later.
foreach my $root ( @roots ) {
# Prune the tree to get rid of extraneous hypotheticals.
- $root = _prune_subtree( $part, $root, $contig );
+ $root = _prune_subtree_old( $part, $root, $contig );
next unless $root;
# Save this root for our group.
push( @group_roots, $root );
sub _prune_group {
my( $group, $stemma, $graph ) = @_;
- # Get these into a form prune_subtree will recognize. Make a "contighash"
- my $hypohash = {};
- map { $hypohash->{$_} = 1 } @$group;
- # ...with reference values for hypotheticals.
- map { $hypohash->{$_} = [] } $stemma->hypotheticals;
+ my $lacunose = {};
+ map { $lacunose->{$_} = 1 } $stemma->hypotheticals;
+ map { $lacunose->{$_} = 0 } @$group;
# Make our subgraph
my $subgraph = $graph->copy;
- map { $subgraph->delete_vertex( $_ ) unless exists $hypohash->{$_} }
+ map { $subgraph->delete_vertex( $_ ) unless exists $lacunose->{$_} }
$subgraph->vertices;
# ...and find the root.
- my( $root ) = $subgraph->predecessorless_vertices;
# Now prune and return the remaining vertices.
- _prune_subtree( $subgraph, $root, $hypohash );
+ _prune_subtree( $subgraph, $lacunose );
return $subgraph->vertices;
}
sub _prune_subtree {
+ my( $tree, $lacunose ) = @_;
+
+ # Delete lacunose witnesses that have no successors
+ my @orphan_hypotheticals;
+ my $ctr = 0;
+ do {
+ die "Infinite loop on leaves" if $ctr > 100;
+ @orphan_hypotheticals = grep { $lacunose->{$_} }
+ $tree->successorless_vertices;
+ $tree->delete_vertices( @orphan_hypotheticals );
+ $ctr++;
+ } while( @orphan_hypotheticals );
+
+ # Delete lacunose roots that have a single successor
+ my @redundant_root;
+ $ctr = 0;
+ do {
+ die "Infinite loop on roots" if $ctr > 100;
+ @redundant_root = grep { $lacunose->{$_} && $tree->successors( $_ ) == 1 }
+ $tree->predecessorless_vertices;
+ $tree->delete_vertices( @redundant_root );
+ $ctr++;
+ } while( @redundant_root );
+}
+
+sub _prune_subtree_old {
my( $tree, $root, $contighash ) = @_;
# First, delete hypothetical leaves / orphans until there are none left.
my @orphan_hypotheticals = grep { ref( $contighash->{$_} ) }
projects / scpubgit/stemmatology.git / blobdiff