1 package Text::Tradition::Analysis;
5 use Algorithm::Diff; # for word similarity measure
7 use Encode qw/ encode_utf8 /;
10 use JSON qw/ encode_json decode_json /;
13 use Text::Tradition::Stemma;
16 use vars qw/ @EXPORT_OK /;
17 @EXPORT_OK = qw/ run_analysis group_variants analyze_variant_location wit_stringify /;
19 my $SOLVER_URL = 'http://byzantini.st/cgi-bin/graphcalc.cgi';
24 Text::Tradition::Analysis - functions for stemma analysis of a tradition
29 use Text::Tradition::Analysis qw/ run_analysis analyze_variant_location /;
30 my $t = Text::Tradition->new(
31 'name' => 'this is a text',
33 'file' => '/path/to/tei_parallel_seg_file.xml' );
34 $t->add_stemma( 'dotfile' => $stemmafile );
36 my $variant_data = run_analysis( $tradition );
37 # Recalculate rank $n treating all orthographic variants as equivalent
38 my $reanalyze = analyze_variant_location( $tradition, $n, 0, 'orthographic' );
42 Text::Tradition is a library for representation and analysis of collated
43 texts, particularly medieval ones. The Collation is the central feature of
44 a Tradition, where the text, its sequence of readings, and its relationships
45 between readings are actually kept.
49 =head2 run_analysis( $tradition, %opts )
51 Runs the analysis described in analyze_variant_location on every location in the
52 collation of the given tradition, with the given options. These include:
56 =item * stemma_id - Specify which of the tradition's stemmata to use. Default
57 is 0 (i.e. the first).
59 =item * ranks - Specify a list of location ranks to analyze; exclude the rest.
61 =item * merge_types - Specify a list of relationship types, where related readings
62 should be treated as identical for the purposes of analysis.
64 =item * exclude_type1 - Exclude those ranks whose groupings have only type-1 variants.
71 use Text::Tradition::Analysis qw/ run_analysis analyze_variant_location /;
73 my $datafile = 't/data/florilegium_tei_ps.xml';
74 my $tradition = Text::Tradition->new( 'input' => 'TEI',
76 'file' => $datafile );
77 my $s = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
78 is( ref( $s ), 'Text::Tradition::Stemma', "Added stemma to tradition" );
80 my %expected_genealogical = (
111 my $data = run_analysis( $tradition );
112 my $c = $tradition->collation;
113 foreach my $row ( @{$data->{'variants'}} ) {
114 # Account for rows that used to be "not useful"
115 unless( exists $expected_genealogical{$row->{'id'}} ) {
116 $expected_genealogical{$row->{'id'}} = 1;
118 my $gen_bool = $row->{'genealogical'} ? 1 : 0;
119 is( $gen_bool, $expected_genealogical{$row->{'id'}},
120 "Got correct genealogical flag for row " . $row->{'id'} );
121 # Check that we have the right row with the right groups
122 my $rank = $row->{'id'};
123 foreach my $rdghash ( @{$row->{'readings'}} ) {
124 # Skip 'readings' that aren't really
125 next unless $c->reading( $rdghash->{'readingid'} );
127 is( $c->reading( $rdghash->{'readingid'} )->rank, $rank,
128 "Got correct reading rank" );
129 # Check the witnesses
130 my @realwits = sort $c->reading_witnesses( $rdghash->{'readingid'} );
131 my @sgrp = sort @{$rdghash->{'group'}};
132 is_deeply( \@sgrp, \@realwits, "Reading analyzed with correct groups" );
135 is( $data->{'variant_count'}, 58, "Got right total variant number" );
136 # TODO Make something meaningful of conflict count, maybe test other bits
143 my( $tradition, %opts ) = @_;
144 my $c = $tradition->collation;
146 my $stemma_id = $opts{'stemma_id'} || 0;
147 my @ranks = ref( $opts{'ranks'} ) eq 'ARRAY' ? @{$opts{'ranks'}} : ();
148 my @collapse = ref( $opts{'merge_types'} ) eq 'ARRAY' ? @{$opts{'merge_types'}} : ();
151 my $stemma = $tradition->stemma( $stemma_id );
153 # Figure out which witnesses we are working with - that is, the ones that
154 # appear both in the stemma and in the tradition. All others are 'lacunose'
156 my @lacunose = $stemma->hypotheticals;
157 my @tradition_wits = map { $_->sigil } $tradition->witnesses;
158 push( @lacunose, _symmdiff( [ $stemma->witnesses ], \@tradition_wits ) );
160 # Find and mark 'common' ranks for exclusion, unless they were
161 # explicitly specified.
164 foreach my $rdg ( $c->common_readings ) {
165 $common_rank{$rdg->rank} = 1;
167 @ranks = grep { !$common_rank{$_} } ( 1 .. $c->end->rank-1 );
170 # Group the variants to send to the solver
175 foreach my $rank ( @ranks ) {
176 my $missing = [ @lacunose ];
177 my $rankgroup = group_variants( $tradition, $rank, $missing, $moved, \@collapse );
178 # Filter out any empty rankgroups
179 # (e.g. from the later rank for a transposition)
180 next unless keys %$rankgroup;
181 if( $opts{'exclude_type1'} ) {
182 # Check to see whether this is a "useful" group.
183 my( $rdgs, $grps ) = _useful_variant( $rankgroup,
184 $stemma->graph, $c->ac_label );
187 push( @use_ranks, $rank );
188 push( @groups, $rankgroup );
189 $lacunae{$rank} = $missing;
192 my $answer = solve_variants( $stemma, @groups );
194 # Do further analysis on the answer
195 my $conflict_count = 0;
196 my $aclabel = $c->ac_label;
197 foreach my $idx ( 0 .. $#use_ranks ) {
198 my $location = $answer->{'variants'}->[$idx];
199 # Add the rank back in
200 my $rank = $use_ranks[$idx];
201 $location->{'id'} = $rank;
202 # Note what our lacunae are
204 map { $lmiss{$_} = 1 } @{$lacunae{$use_ranks[$idx]}};
205 $location->{'missing'} = [ keys %lmiss ];
207 # Run the extra analysis we need.
208 ## TODO We run through all the variants in this call, so
209 ## why not add the reading data there instead of here below?
210 analyze_location( $tradition, $stemma, $location, \%lmiss );
213 # Do the final post-analysis tidying up of the data.
214 foreach my $rdghash ( @{$location->{'readings'}} ) {
216 if exists $rdghash->{'conflict'} && $rdghash->{'conflict'};
217 # Add the reading text back in, setting display value as needed
218 my $rdg = $c->reading( $rdghash->{'readingid'} );
220 $rdghash->{'text'} = $rdg->text .
221 ( $rdg->rank == $rank ? '' : ' [' . $rdg->rank . ']' );
222 $rdghash->{'is_ungrammatical'} = $rdg->grammar_invalid;
223 $rdghash->{'is_nonsense'} = $rdg->is_nonsense;
225 # Remove lacunose witnesses from this reading's list now that the
228 map { push( @realgroup, $_ ) unless $lmiss{$_} } @{$rdghash->{'group'}};
229 $rdghash->{'group'} = \@realgroup;
230 # Note any layered witnesses that appear in this group
231 foreach( @realgroup ) {
232 if( $_ =~ /^(.*)\Q$aclabel\E$/ ) {
233 push( @layerwits, $1 );
237 $location->{'layerwits'} = \@layerwits if @layerwits;
239 $answer->{'conflict_count'} = $conflict_count;
244 =head2 group_variants( $tradition, $rank, $lacunose, @merge_relationship_types )
246 Groups the variants at the given $rank of the collation, treating any
247 relationships in @merge_relationship_types as equivalent. $lacunose should
248 be a reference to an array, to which the sigla of lacunose witnesses at this
249 rank will be appended; $transposed should be a reference to a hash, wherein
250 the identities of transposed readings and their relatives will be stored.
252 Returns a hash $group_readings where $rdg is attested by the witnesses listed
253 in $group_readings->{$rdg}.
257 # Return group_readings, groups, lacunose
259 my( $tradition, $rank, $lacunose, $transposed, $collapse ) = @_;
260 my $c = $tradition->collation;
261 my $aclabel = $c->ac_label;
262 my $table = $c->alignment_table;
263 # Get the alignment table readings
264 my %readings_at_rank;
265 my %is_lacunose; # lookup table for witnesses not in stemma
266 map { $is_lacunose{$_} = 1; $is_lacunose{$_.$aclabel} = 1 } @$lacunose;
269 my $has_transposition;
270 foreach my $tablewit ( @{$table->{'alignment'}} ) {
271 my $rdg = $tablewit->{'tokens'}->[$rank-1];
272 my $wit = $tablewit->{'witness'};
273 # Exclude the witness if it is "lacunose" which if we got here
274 # means "not in the stemma".
275 next if $is_lacunose{$wit};
276 # Note if the witness is actually in a lacuna
277 if( $rdg && $rdg->{'t'}->is_lacuna ) {
278 _add_to_witlist( $wit, $lacunose, $aclabel );
279 # Otherwise the witness either has a positive reading...
281 # If the reading has been counted elsewhere as a transposition, ignore it.
282 if( $transposed->{$rdg->{'t'}->id} ) {
283 # TODO Does this cope with three-way transpositions?
284 map { $moved_wits{$_} = 1 } @{$transposed->{$rdg->{'t'}->id}};
287 # Otherwise, record it...
288 $readings_at_rank{$rdg->{'t'}->id} = $rdg->{'t'};
289 # ...and grab any transpositions, and their relations.
290 my @transp = grep { $_->rank != $rank } $rdg->{'t'}->related_readings();
291 foreach my $trdg ( @transp ) {
292 next if exists $readings_at_rank{$trdg->id};
293 $has_transposition = 1;
294 my @affected_wits = _table_witnesses(
295 $table, $trdg, \%is_lacunose, $aclabel );
296 next unless @affected_wits;
297 map { $moved_wits{$_} = 1 } @affected_wits;
298 $transposed->{$trdg->id} =
299 [ _table_witnesses( $table, $rdg->{'t'}, \%is_lacunose, $aclabel ) ];
300 $readings_at_rank{$trdg->id} = $trdg;
302 # ...or it is empty, ergo a gap.
304 _add_to_witlist( $wit, \@check_for_gaps, $aclabel );
308 map { _add_to_witlist( $_, \@gap_wits, $aclabel )
309 unless $moved_wits{$_} } @check_for_gaps;
310 # Group the readings, collapsing groups by relationship if needed
311 my $grouped_readings = {};
312 foreach my $rdg ( values %readings_at_rank ) {
313 # Skip readings that have been collapsed into others.
314 next if exists $grouped_readings->{$rdg->id}
315 && $grouped_readings->{$rdg->id} eq 'COLLAPSE';
316 # Get the witness list, including from readings collapsed into this one.
317 my @wits = _table_witnesses( $table, $rdg, \%is_lacunose, $aclabel );
318 if( $collapse && @$collapse ) {
319 my $filter = sub { my $r = $_[0]; grep { $_ eq $r->type } @$collapse; };
320 foreach my $other ( $rdg->related_readings( $filter ) ) {
321 my @otherwits = _table_witnesses(
322 $table, $other, \%is_lacunose, $aclabel );
323 push( @wits, @otherwits );
324 $grouped_readings->{$other->id} = 'COLLAPSE';
327 $grouped_readings->{$rdg->id} = \@wits;
329 $grouped_readings->{'(omitted)'} = \@gap_wits if @gap_wits;
330 # Get rid of our collapsed readings
331 map { delete $grouped_readings->{$_} if $grouped_readings->{$_} eq 'COLLAPSE' }
332 keys %$grouped_readings
335 # If something was transposed, check the groups for doubled-up readings
336 if( $has_transposition ) {
337 # print STDERR "Group for rank $rank:\n";
338 # map { print STDERR "\t$_: " . join( ' ' , @{$grouped_readings->{$_}} ) . "\n" }
339 # keys %$grouped_readings;
340 _check_transposed_consistency( $c, $rank, $transposed, $grouped_readings );
344 return $grouped_readings;
347 # Helper function to query the alignment table for all witnesses (a.c. included)
348 # that have a given reading at its rank.
349 sub _table_witnesses {
350 my( $table, $trdg, $lacunose, $aclabel ) = @_;
351 my $tableidx = $trdg->rank - 1;
353 foreach my $row ( @{$table->{'alignment'}} ) {
354 my $wit = $row->{'witness'};
355 next if $lacunose->{$wit};
356 my $rdg = $row->{'tokens'}->[$tableidx];
357 next unless exists $rdg->{'t'} && defined $rdg->{'t'};
358 _add_to_witlist( $wit, \@has_reading, $aclabel )
359 if $rdg->{'t'}->id eq $trdg->id;
364 # Helper function to ensure that X and X a.c. never appear in the same list.
365 sub _add_to_witlist {
366 my( $wit, $list, $acstr ) = @_;
369 map { $inlist{$_} = $idx++ } @$list;
370 if( $wit =~ /^(.*)\Q$acstr\E$/ ) {
372 unless( exists $inlist{$acwit} ) {
373 push( @$list, $acwit.$acstr );
376 if( exists( $inlist{$wit.$acstr} ) ) {
377 # Replace the a.c. version with the main witness
378 my $i = $inlist{$wit.$acstr};
381 push( @$list, $wit );
386 sub _check_transposed_consistency {
387 my( $c, $rank, $transposed, $groupings ) = @_;
390 # Note which readings are actually at this rank, and which witnesses
391 # belong to which reading.
392 foreach my $rdg ( keys %$groupings ) {
393 my $rdgobj = $c->reading( $rdg );
394 # Count '(omitted)' as a reading at this rank
395 $thisrank{$rdg} = 1 if !$rdgobj || $rdgobj->rank == $rank;
396 map { push( @{$seen_wits{$_}}, $rdg ) } @{$groupings->{$rdg}};
398 # Our work is done if we have no witness belonging to more than one
400 my @doubled = grep { scalar @{$seen_wits{$_}} > 1 } keys %seen_wits;
401 return unless @doubled;
402 # If we have a symmetric related transposition, drop the non-rank readings.
403 if( @doubled == scalar keys %seen_wits ) {
404 foreach my $rdg ( keys %$groupings ) {
405 if( !$thisrank{$rdg} ) {
406 my $groupstr = wit_stringify( $groupings->{$rdg} );
407 my ( $matched ) = grep { $groupstr eq wit_stringify( $groupings->{$_} ) }
409 delete $groupings->{$rdg};
410 # If we found a group match, assume there is a symmetry happening.
411 # TODO think more about this
412 # print STDERR "*** Deleting symmetric reading $rdg\n";
414 delete $transposed->{$rdg};
415 warn "Found problem in evident symmetry with reading $rdg";
419 # Otherwise 'unhook' the transposed reading(s) that have duplicates.
421 foreach my $dup ( @doubled ) {
422 foreach my $rdg ( @{$seen_wits{$dup}} ) {
423 next if $thisrank{$rdg};
424 next unless exists $groupings->{$rdg};
425 # print STDERR "*** Deleting asymmetric doubled-up reading $rdg\n";
426 delete $groupings->{$rdg};
427 delete $transposed->{$rdg};
430 # and put any now-orphaned readings into an 'omitted' reading.
431 foreach my $wit ( keys %seen_wits ) {
432 unless( grep { exists $groupings->{$_} } @{$seen_wits{$wit}} ) {
433 $groupings->{'(omitted)'} = [] unless exists $groupings->{'(omitted)'};
434 _add_to_witlist( $wit, $groupings->{'(omitted)'}, $c->ac_label );
440 =head2 solve_variants( $graph, @groups )
442 Sends the set of groups to the external graph solver service and returns
443 a cleaned-up answer, adding the rank IDs back where they belong.
445 The JSON has the form
446 { "graph": [ stemmagraph DOT string without newlines ],
447 "groupings": [ array of arrays of groups, one per rank ] }
449 The answer has the form
450 { "variants" => [ array of variant location structures ],
451 "variant_count" => total,
452 "conflict_count" => number of conflicts detected,
453 "genealogical_count" => number of solutions found }
458 my( $stemma, @groups ) = @_;
460 # Filter the groups down to distinct groups, and work out what graph
461 # should be used in the calculation of each group. We want to send each
462 # distinct problem to the solver only once.
463 # We need a whole bunch of lookup tables for this.
464 my( $index_groupkeys, $group_indices, $graph_problems ) = _prepare_groups( @_ );
466 ## For each distinct graph, send its groups to the solver.
467 my $ua = LWP::UserAgent->new();
468 ## Witness map is a HACK to get around limitations in node names from IDP
469 my $witness_map = {};
470 ## Variables to store answers as they come back
471 my $variants = [ ( undef ) x ( scalar keys %$index_groupkeys ) ];
472 my $genealogical = 0;
473 foreach my $graphkey ( keys %$graph_problems ) {
474 my $graph = $graph_problems->{$graphkey}->{'object'};
475 my $groupings = [ values %{$graph_problems->{$graphkey}->{'groups'}} ];
476 my $req = _safe_wit_strings( $graph, $stemma->collation,
477 $groupings, $witness_map );
478 $req->{'command'} = 'findGroupings';
479 my $json = encode_json( $req );
480 # Send it off and get the result
481 # print STDERR "Sending request: " . to_json( $req ) . "\n";
482 my $resp = $ua->post( $SOLVER_URL, 'Content-Type' => 'application/json',
483 'Content' => $json );
485 if( $resp->is_success ) {
486 $answer = _desanitize_names( decode_json( $resp->content ), $witness_map );
488 # Fall back to the old method.
489 die "IDP solver returned " . $resp->status_line . " / " . $resp->content
490 . "; cannot run graph analysis";
493 ## If IDP worked, asked it the other two questions for this dataset.
495 foreach my $test ( qw/ findSources findClasses / ) {
496 $req->{'command'} = $test;
497 $json = encode_json( $req );
498 $resp = $ua->post( $SOLVER_URL, 'Content-Type' => 'application/json',
499 'Content' => $json );
500 if( $resp->is_success ) {
501 $more_eval->{$test} = _desanitize_names(
502 decode_json( $resp->content ), $witness_map );
504 warn "IDP solver for $test returned " . $resp->status_line .
505 " / " . $resp->content;
506 # TODO arrange fallback
510 ## The answer is the evaluated groupings, plus a boolean for whether
511 ## they were genealogical. Reconstruct our original groups.
512 foreach my $gidx ( 0 .. $#{$groupings} ) {
513 my( $calc_groups, $result ) = @{$answer->[$gidx]};
514 # Keep track of the total # of genealogical readings
515 $genealogical++ if $result;
517 my( $sources, $classes );
518 # Use the expanded groups from findSources if that got calculated.
519 if( exists( $more_eval->{'findSources'} ) ) {
520 ( $calc_groups, $sources ) = @{$more_eval->{'findSources'}->[$gidx]};
522 # Use the (same) expanded groups from findClasses if that got calculated
524 if( exists( $more_eval->{'findClasses'} ) && !$result ) {
525 my $throwaway_groups;
526 ( $throwaway_groups, $classes ) = @{$more_eval->{'findClasses'}->[$gidx]};
529 # Convert the source list into a lookup hash
531 map { $roots->{$_} = 1 } @$sources;
532 # Convert the class list into a lookup hash
534 $classes = _invert_hash( $classes );
537 # Retrieve the key for the original group that went to the solver
538 my $input_group = wit_stringify( $groupings->[$gidx] );
540 # Make the variant hash for each location that had this particular
541 # grouping on this particular stemma situation
542 foreach my $oidx ( @{$group_indices->{$input_group}} ) {
543 my @readings = @{$index_groupkeys->{$oidx}};
545 'genealogical' => $result,
548 foreach my $ridx ( 0 .. $#readings ) {
549 push( @{$vstruct->{'readings'}},
550 { 'readingid' => $readings[$ridx],
551 'group' => $calc_groups->[$ridx] } );
553 $vstruct->{'reading_roots'} = $roots if $roots;
554 $vstruct->{'reading_types'} = $classes if $classes;
555 $variants->[$oidx] = $vstruct;
560 return { 'variants' => $variants,
561 'variant_count' => scalar @$variants,
562 'genealogical_count' => $genealogical };
565 sub _prepare_groups {
566 my( $stemma, @groups ) = @_;
567 my $aclabel = $stemma->collation->ac_label;
569 my $index_groupkeys = {}; # Save the order of readings
570 my $group_indices = {}; # Save the indices that have a given grouping
571 my $graph_problems = {}; # Save the groupings for the given graph
573 foreach my $idx ( 0..$#groups ) {
574 my $ghash = $groups[$idx];
576 # Sort the groupings from big to little, and scan for a.c. witnesses
577 # that would need an extended graph.
578 my @acwits; # note which AC witnesses crop up at this rank
579 my $extant; # note which witnesses crop up at this rank full stop
580 my @idxkeys = sort { scalar @{$ghash->{$b}} <=> scalar @{$ghash->{$a}} }
582 foreach my $rdg ( @idxkeys ) {
583 my @sg = sort @{$ghash->{$rdg}};
584 push( @acwits, grep { $_ =~ /\Q$aclabel\E$/ } @sg );
585 map { $extant->{$_} = 1 } @sg;
586 push( @grouping, \@sg );
588 # Save the reading order
589 $index_groupkeys->{$idx} = \@idxkeys;
591 # Now associate the distinct group with this index
592 my $gstr = wit_stringify( \@grouping );
593 push( @{$group_indices->{$gstr}}, $idx );
595 # Finally, add the group to the list to be calculated for this graph.
596 map { s/\Q$aclabel\E$// } @acwits;
598 ## TODO When we get rid of the safe_wit_strings HACK we should also
599 ## be able to save the graph here as a dotstring rather than as an
600 ## object, thus simplifying life enormously.
602 $graph = $stemma->situation_graph( $extant, \@acwits );
604 die "Unable to extend graph with @acwits";
606 my $graphkey = "$graph || " . wit_stringify( [ sort keys %$extant ] );
607 unless( exists $graph_problems->{$graphkey} ) {
608 $graph_problems->{$graphkey} = { 'object' => $graph, 'groups' => {} };
610 $graph_problems->{$graphkey}->{'groups'}->{wit_stringify( \@grouping )} = \@grouping;
612 say STDERR "Created " . scalar( keys %$graph_problems ). " distinct graph(s)";
613 return( $index_groupkeys, $group_indices, $graph_problems );
616 #### HACKERY to cope with IDP's limited idea of what a node name looks like ###
618 sub _safe_wit_strings {
619 my( $graph, $c, $groupings, $witness_map ) = @_;
620 # Convert the graph to a safe representation and store the conversion.
621 my $safegraph = Graph->new();
622 foreach my $n ( $graph->vertices ) {
623 my $sn = _safe_witstr( $n );
624 if( exists $witness_map->{$sn} ) {
625 warn "Ambiguous stringification $sn for $n and " . $witness_map->{$sn}
626 if $witness_map->{$sn} ne $n;
628 $witness_map->{$sn} = $n;
630 $safegraph->add_vertex( $sn );
631 $safegraph->set_vertex_attributes( $sn,
632 $graph->get_vertex_attributes( $n ) );
634 foreach my $e ( $graph->edges ) {
635 my @safe_e = ( _safe_witstr( $e->[0] ), _safe_witstr( $e->[1] ) );
636 $safegraph->add_edge( @safe_e );
639 # Now convert the witness groupings to a safe representation.
640 my $safe_groupings = [];
641 foreach my $grouping ( @$groupings ) {
642 my $safe_grouping = [];
643 foreach my $group ( @$grouping ) {
645 foreach my $n ( @$group ) {
646 my $sn = _safe_witstr( $n );
647 warn "Ambiguous stringification $sn for $n and " . $witness_map->{$sn}
648 if exists $witness_map->{$sn} && $witness_map->{$sn} ne $n;
649 $witness_map->{$sn} = $n;
650 push( @$safe_group, $sn );
652 push( @$safe_grouping, $safe_group );
654 push( @$safe_groupings, $safe_grouping );
657 # Return it all in the struct we expect. We have stored the reductions
658 # in the $witness_map that we were passed.
659 return { 'graph' => Text::Tradition::Stemma::editable_graph(
660 $safegraph, { 'linesep' => ' ' } ),
661 'groupings' => $safe_groupings };
666 $witstr =~ s/\s+/_/g;
667 $witstr =~ s/[^\w\d-]//g;
671 sub _desanitize_names {
672 my( $element, $witness_map ) = @_;
674 if( ref( $element ) eq 'ARRAY' ) {
675 foreach my $n ( @$element ) {
676 push( @$result, _desanitize_names( $n, $witness_map ) );
678 } elsif( ref( $element ) eq 'HASH' ) {
680 map { $real_hash->{$_} = _desanitize_names( $element->{$_}, $witness_map ) }
682 $result = $real_hash;
683 } elsif( exists $witness_map->{$element} ) {
684 $result = $witness_map->{$element}
694 foreach my $k ( keys %$hash ) {
695 if( ref( $hash->{$k} ) eq 'ARRAY' ) {
696 foreach my $v ( @{$hash->{$k}} ) {
700 $newhash->{$hash->{$k}} = $k;
708 =head2 analyze_location ( $tradition, $graph, $location_hash )
710 Given the tradition, its stemma graph, and the solution from the graph solver,
711 work out the rest of the information we want. For each reading we need missing,
712 conflict, reading_parents, independent_occurrence, followed, not_followed,
713 and follow_unknown. Alters the location_hash in place.
717 sub analyze_location {
718 my ( $tradition, $stemma, $variant_row, $lacunose ) = @_;
719 my $c = $tradition->collation;
721 # Make a hash of all known node memberships, and make the subgraphs.
723 my $reading_roots = {};
725 my $acstr = $c->ac_label;
729 if( exists $variant_row->{'reading_roots'} ) {
730 $reading_roots = delete $variant_row->{'reading_roots'};
732 warn "No reading source information from IDP - proceed at your own risk";
736 # Note which witnesses positively belong to which group. This information
737 # comes ultimately from the IDP solver.
738 # Also make a note of the reading's roots.
739 foreach my $rdghash ( @{$variant_row->{'readings'}} ) {
740 my $rid = $rdghash->{'readingid'};
742 foreach my $wit ( @{$rdghash->{'group'}} ) {
743 $contig->{$wit} = $rid;
744 if( $wit =~ /^(.*)\Q$acstr\E$/ ) {
747 if( exists $reading_roots->{$wit} && $reading_roots->{$wit} ) {
748 push( @roots, $wit );
751 $rdghash->{'independent_occurrence'} = \@roots;
754 # Get the actual graph we should work with
757 # contig contains all extant wits and all hypothetical wits
758 # needed to make up the groups.
759 $graph = $stemma->situation_graph( $contig, \@acwits );
760 } catch ( Text::Tradition::Error $e ) {
761 die "Could not extend graph with given extant and a.c. witnesses: "
764 die "Could not extend graph with a.c. witnesses @acwits";
768 # Now that we have all the node group memberships, calculate followed/
769 # non-followed/unknown values for each reading. Also figure out the
770 # reading's evident parent(s).
771 foreach my $rdghash ( @{$variant_row->{'readings'}} ) {
772 my $rid = $rdghash->{'readingid'};
773 my $rdg = $c->reading( $rid );
774 my @roots = @{$rdghash->{'independent_occurrence'}};
775 my @group = @{$rdghash->{'group'}};
777 # Start figuring things out.
778 $rdghash->{'followed'} = scalar( @group ) - scalar( @roots );
779 # Find the parent readings, if any, of this reading.
781 foreach my $wit ( @roots ) {
782 # Look in the stemma graph to find this witness's extant or known-reading
783 # immediate ancestor(s), and look up the reading that each ancestor olds.
784 my @check = $graph->predecessors( $wit );
787 foreach my $wparent( @check ) {
788 my $preading = $contig->{$wparent};
789 if( $preading && $preading ne $rid ) {
790 $rdgparents->{$preading} = 1;
792 push( @next, $graph->predecessors( $wparent ) );
798 foreach my $p ( keys %$rdgparents ) {
799 # Resolve the relationship of the parent to the reading, and
800 # save it in our hash.
801 my $pobj = $c->reading( $p );
802 my $prep = $pobj ? $pobj->id . ' (' . $pobj->text . ')' : $p;
803 my $phash = { 'label' => $prep };
805 my $rel = $c->get_relationship( $p, $rdghash->{readingid} );
807 _add_to_hash( $rel, $phash );
809 # First check for a transposed relationship
810 if( $rdg->rank != $pobj->rank ) {
811 foreach my $ti ( $rdg->related_readings( 'transposition' ) ) {
812 next unless $ti->text eq $rdg->text;
813 $rel = $c->get_relationship( $ti, $pobj );
815 _add_to_hash( $rel, $phash, 1 );
820 foreach my $ti ( $pobj->related_readings( 'transposition' ) ) {
821 next unless $ti->text eq $pobj->text;
822 $rel = $c->get_relationship( $ti, $rdg );
824 _add_to_hash( $rel, $phash, 1 );
831 # and then check for sheer word similarity.
832 my $rtext = $rdg->text;
833 my $ptext = $pobj->text;
834 if( similar( $rtext, $ptext ) ) {
835 # say STDERR "Words $rtext and $ptext judged similar";
836 $phash->{relation} = { type => 'wordsimilar' };
840 $phash->{relation} = { type => 'deletion' };
842 # Get the attributes of the parent object while we are here
843 $phash->{'text'} = $pobj->text if $pobj;
844 $phash->{'is_nonsense'} = $pobj->is_nonsense;
845 $phash->{'is_ungrammatical'} = $pobj->grammar_invalid;
846 } elsif( $p eq '(omitted)' ) {
847 $phash->{relation} = { type => 'addition' };
850 $rdgparents->{$p} = $phash;
853 $rdghash->{'reading_parents'} = $rdgparents;
855 # Find the number of times this reading was altered, and the number of
856 # times we're not sure.
857 my( %nofollow, %unknownfollow );
858 foreach my $wit ( @{$rdghash->{'group'}} ) {
859 foreach my $wchild ( $graph->successors( $wit ) ) {
860 if( $reading_roots->{$wchild} && $contig->{$wchild}
861 && $contig->{$wchild} ne $rid ) {
862 # It definitely changed here.
863 $nofollow{$wchild} = 1;
864 } elsif( !($contig->{$wchild}) ) {
865 # The child is a hypothetical node not definitely in
866 # any group. Answer is unknown.
867 $unknownfollow{$wchild} = 1;
868 } # else it is either in our group, or it is a non-root node in a
869 # known group and therefore is presumed to have its reading from
870 # its group, not this link.
873 $rdghash->{'not_followed'} = keys %nofollow;
874 $rdghash->{'follow_unknown'} = keys %unknownfollow;
876 # Now say whether this reading represents a conflict.
877 unless( $variant_row->{'genealogical'} ) {
879 if( exists $variant_row->{'reading_types'} ) {
880 my $classinfo = delete $variant_row->{'reading_types'};
881 # We have tested for reversions. Use the information.
883 foreach my $rdgroot ( @roots ) {
884 if( $classinfo->{$rdgroot} eq 'revert' ) {
885 push( @reversions, $rdgroot );
887 push( @trueroots, $rdgroot );
890 $rdghash->{'independent_occurrence'} = \@trueroots;
891 $rdghash->{'reversion'} = \@reversions if @reversions;
895 $rdghash->{'conflict'} = @trueroots != 1;
901 my( $rel, $phash, $is_transposed ) = @_;
902 $phash->{relation} = { type => $rel->type };
903 $phash->{relation}->{transposed} = 1 if $is_transposed;
904 $phash->{relation}->{annotation} = $rel->annotation
905 if $rel->has_annotation;
908 =head2 similar( $word1, $word2 )
910 Use Algorithm::Diff to get a sense of how close the words are to each other.
911 This will hopefully handle substitutions a bit more nicely than Levenshtein.
918 my( $word1, $word2 ) = sort { length($a) <=> length($b) } @_;
919 my @let1 = split( '', lc( $word1 ) );
920 my @let2 = split( '', lc( $word2 ) );
921 my $diff = Algorithm::Diff->new( \@let1, \@let2 );
923 while( $diff->Next ) {
925 # Take off points for longer strings
926 my $cs = $diff->Range(1) - 2;
929 } elsif( !$diff->Items(1) ) {
930 $mag += $diff->Range(2);
931 } elsif( !$diff->Items(2) ) {
932 $mag += $diff->Range(1);
934 # Split the difference for substitutions
935 my $c1 = $diff->Range(1) || 1;
936 my $c2 = $diff->Range(2) || 1;
937 my $cd = ( $c1 + $c2 ) / 2;
941 return ( $mag <= length( $word1 ) / 2 );
945 my( $group, $graph ) = @_;
947 # Record the existence of the vertices in the group
948 map { $relevant->{$_} = 1 } @$group;
950 my $subgraph = $graph->deep_copy;
951 map { $subgraph->delete_vertex( $_ ) unless $relevant->{$_} }
953 # Now prune and return the remaining vertices.
954 _prune_subtree( $subgraph );
955 # Return the list of vertices and the list of roots.
956 my $pruned_group = [ sort $subgraph->vertices ];
957 my $pruned_roots = [ $subgraph->predecessorless_vertices ];
958 return( $pruned_group, $pruned_roots );
964 # Delete lacunose witnesses that have no successors
965 my @orphan_hypotheticals;
968 die "Infinite loop on leaves" if $ctr > 100;
969 @orphan_hypotheticals =
970 grep { $tree->get_vertex_attribute( $_, 'class' ) eq 'hypothetical' }
971 $tree->successorless_vertices;
972 $tree->delete_vertices( @orphan_hypotheticals );
974 } while( @orphan_hypotheticals );
976 # Delete lacunose roots that have a single successor
980 die "Infinite loop on roots" if $ctr > 100;
982 grep { $tree->get_vertex_attribute( $_, 'class' ) eq 'hypothetical'
983 && $tree->successors( $_ ) == 1 }
984 $tree->predecessorless_vertices;
985 $tree->delete_vertices( @redundant_root );
987 } while( @redundant_root );
990 sub _useful_variant {
991 my( $group_readings, $graph, $acstr ) = @_;
993 # TODO Decide what to do with AC witnesses
995 # Sort by group size and return
997 my( @readings, @groups ); # The sorted groups for our answer.
998 foreach my $rdg ( sort { @{$group_readings->{$b}} <=> @{$group_readings->{$a}} }
999 keys %$group_readings ) {
1000 push( @readings, $rdg );
1001 push( @groups, $group_readings->{$rdg} );
1002 if( @{$group_readings->{$rdg}} > 1 ) {
1005 my( $wit ) = @{$group_readings->{$rdg}};
1006 $wit =~ s/^(.*)\Q$acstr\E$/$1/;
1007 $is_useful++ unless( $graph->is_sink_vertex( $wit ) );
1010 if( $is_useful > 1 ) {
1011 return( \@readings, \@groups );
1017 =head2 wit_stringify( $groups )
1019 Takes an array of witness groupings and produces a string like
1020 ['A','B'] / ['C','D','E'] / ['F']
1027 # If we were passed an array of witnesses instead of an array of
1028 # groupings, then "group" the witnesses first.
1029 unless( ref( $groups->[0] ) ) {
1030 my $mkgrp = [ $groups ];
1033 foreach my $g ( @$groups ) {
1034 push( @gst, '[' . join( ',', map { "'$_'" } @$g ) . ']' );
1036 return join( ' / ', @gst );
1040 my( $lista, $listb ) = @_;
1043 map { $union{$_} = 1; $scalars{$_} = $_ } @$lista;
1044 map { $union{$_} += 1; $scalars{$_} = $_ } @$listb;
1045 my @set = grep { $union{$_} == 1 } keys %union;
1046 return map { $scalars{$_} } @set;
1053 This package is free software and is provided "as is" without express
1054 or implied warranty. You can redistribute it and/or modify it under
1055 the same terms as Perl itself.
1059 Tara L Andrews E<lt>aurum@cpan.orgE<gt>