analysis/lib/Text/Tradition/Analysis.pm

   1 package Text::Tradition::Analysis;
   2
   3 use strict;
   4 use warnings;
   5 use Algorithm::Diff;  # for word similarity measure
   6 use Encode qw/ decode_utf8 encode_utf8 /;
   7 use Exporter 'import';
   8 use Graph;
   9 use JSON qw/ to_json decode_json /;
  10 use LWP::UserAgent;
  11 use Set::Scalar;
  12 use Text::Tradition::Analysis::Result;
  13 use Text::Tradition::Stemma;
  14 use TryCatch;
  15
  16 use vars qw/ @EXPORT_OK $VERSION /;
  17 @EXPORT_OK = qw/ run_analysis group_variants analyze_variant_location wit_stringify /;
  18 $VERSION = "1.1";
  19
  20
  21 my $SOLVER_URL = 'http://byzantini.st/cgi-bin/graphcalc.cgi';
  22 my $unsolved_problems = {};
  23
  24 =head1 NAME
  25
  26 Text::Tradition::Analysis - functions for stemma analysis of a tradition
  27
  28 =head1 DESCRIPTION
  29
  30 Text::Tradition is a library for representation and analysis of collated
  31 texts, particularly medieval ones.  Where the Collation is the central
  32 feature of a Tradition, it may also have one or more stemmata associated
  33 with it, and these stemmata may be analyzed. This package provides the
  34 following modules:
  35
  36 =over 4
  37
  38 =item * L<Text::Tradition::HasStemma> - a role that will be composed into
  39 Text::Tradition objects, providing the ability for Text::Tradition::Stemma
  40 objects to be associated with them.
  41
  42 =item * L<Text::Tradition::Stemma> - an object class that represents stemma
  43 hypotheses, both rooted (with a single archetype) and unrooted (e.g.
  44 phylogenetic trees).
  45
  46 =item * Text::Tradition::Analysis (this package). Provides functions for
  47 the analysis of a given stemma against the collation within a given
  48 Tradition.
  49
  50 =back
  51
  52 =head1 SYNOPSIS
  53
  54   use Text::Tradition;
  55   use Text::Tradition::Analysis qw/ run_analysis analyze_variant_location /;
  56   my $t = Text::Tradition->new(
  57     'name' => 'this is a text',
  58     'input' => 'TEI',
  59     'file' => '/path/to/tei_parallel_seg_file.xml' );
  60   $t->add_stemma( 'dotfile' => $stemmafile );
  61
  62   my $variant_data = run_analysis( $tradition );
  63
  64 =head1 SUBROUTINES
  65
  66 =head2 run_analysis( $tradition, %opts )
  67
  68 Runs the analysis described in analyze_variant_location on every location in the
  69 collation of the given tradition, with the given options. These include:
  70
  71 =over 4
  72
  73 =item * stemma_id - Specify which of the tradition's stemmata to use. Default
  74 is 0 (i.e. the first).
  75
  76 =item * ranks - Specify a list of location ranks to analyze; exclude the rest.
  77
  78 =item * merge_types - Specify a list of relationship types, where related readings
  79 should be treated as identical for the purposes of analysis.
  80
  81 =item * exclude_type1 - Exclude those ranks whose groupings have only type-1 variants.
  82
  83 =back
  84
  85 =begin testing
  86
  87 use Text::Tradition;
  88 use Text::Tradition::Analysis qw/ run_analysis analyze_variant_location /;
  89
  90 my $datafile = 't/data/florilegium_tei_ps.xml';
  91 my $tradition = Text::Tradition->new( 'input' => 'TEI',
  92                                       'name' => 'test0',
  93                                       'file' => $datafile );
  94 my $s = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
  95 is( ref( $s ), 'Text::Tradition::Stemma', "Added stemma to tradition" );
  96
  97 my %expected_genealogical = (
  98         1 => 0,
  99         2 => 1,
 100         3 =>  0,
 101         5 =>  0,
 102         7 =>  0,
 103         8 =>  0,
 104         10 => 0,
 105         13 => 1,
 106         33 => 0,
 107         34 => 0,
 108         37 => 0,
 109         60 => 0,
 110         81 => 1,
 111         84 => 0,
 112         87 => 0,
 113         101 => 0,
 114         102 => 0,
 115         122 => 1,
 116         157 => 0,
 117         166 => 1,
 118         169 => 1,
 119         200 => 0,
 120         216 => 1,
 121         217 => 1,
 122         219 => 1,
 123         241 => 1,
 124         242 => 1,
 125         243 => 1,
 126 );
 127
 128 my $data = run_analysis( $tradition, calcdsn => 'dbi:SQLite:dbname=t/data/analysis.db' );
 129 my $c = $tradition->collation;
 130 foreach my $row ( @{$data->{'variants'}} ) {
 131         # Account for rows that used to be "not useful"
 132         unless( exists $expected_genealogical{$row->{'id'}} ) {
 133                 $expected_genealogical{$row->{'id'}} = 1;
 134         }
 135         my $gen_bool = $row->{'genealogical'} ? 1 : 0;
 136         is( $gen_bool, $expected_genealogical{$row->{'id'}},
 137                 "Got correct genealogical flag for row " . $row->{'id'} );
 138         # Check that we have the right row with the right groups
 139         my $rank = $row->{'id'};
 140         foreach my $rdghash ( @{$row->{'readings'}} ) {
 141                 # Skip 'readings' that aren't really
 142                 next unless $c->reading( $rdghash->{'readingid'} );
 143                 # Check the rank
 144                 is( $c->reading( $rdghash->{'readingid'} )->rank, $rank,
 145                         "Got correct reading rank" );
 146                 # Check the witnesses
 147                 my @realwits = sort $c->reading_witnesses( $rdghash->{'readingid'} );
 148                 my @sgrp = sort @{$rdghash->{'group'}};
 149                 is_deeply( \@sgrp, \@realwits, "Reading analyzed with correct groups" );
 150         }
 151 }
 152 is( $data->{'variant_count'}, 58, "Got right total variant number" );
 153 # TODO Make something meaningful of conflict count, maybe test other bits
 154
 155 =end testing
 156
 157 =cut
 158
 159 sub run_analysis {
 160         my( $tradition, %opts ) = @_;
 161         my $c = $tradition->collation;
 162         my $aclabel = $c->ac_label;
 163
 164         my $stemma_id = $opts{'stemma_id'} || 0;
 165         my @ranks = ref( $opts{'ranks'} ) eq 'ARRAY' ? @{$opts{'ranks'}} : ();
 166         my $collapse = Set::Scalar->new();
 167         if( $opts{'merge_types'} && ref( $opts{'merge_types'} ) eq 'ARRAY' ) {
 168                 $collapse->insert( @{$opts{'merge_types'}} );
 169         } elsif( $opts{'merge_types'} ) {
 170                 $collapse->insert( $opts{'merge_types'} );
 171         }
 172
 173         # Make sure we have a lookup DB for graph calculation results; this will die
 174         # if calcdir or calcdsn isn't passed.
 175         my $dir;
 176         if( exists $opts{'calcdir'} ) {
 177                 $dir = delete $opts{'calcdir'}
 178         } elsif ( exists $opts{'calcdsn'} ) {
 179                 eval { require Text::Tradition::Directory };
 180                 if( $@ ) {
 181                         throw( "Could not instantiate a directory for " . $opts{'calcdsn'}
 182                                 . ": $@" );
 183                 }
 184                 $dir = Text::Tradition::Directory->new( dsn => $opts{'calcdsn'} );
 185         }
 186
 187         # Get the stemma
 188         my $stemma = $tradition->stemma( $stemma_id );
 189
 190         # Figure out which witnesses we are working with - that is, the ones that
 191         # appear both in the stemma and in the tradition. All others are 'lacunose'
 192         # for our purposes.
 193         my $lacunose = Set::Scalar->new( $stemma->hypotheticals );
 194         my $stemma_wits = Set::Scalar->new( $stemma->witnesses );
 195         my $tradition_wits = Set::Scalar->new( map { $_->sigil } $tradition->witnesses );
 196         $lacunose->insert( $stemma_wits->symmetric_difference( $tradition_wits )->members );
 197
 198         # Find and mark 'common' ranks for exclusion, unless they were
 199         # explicitly specified.
 200         unless( @ranks ) {
 201                 my %common_rank;
 202                 foreach my $rdg ( $c->common_readings ) {
 203                         $common_rank{$rdg->rank} = 1;
 204                 }
 205                 @ranks = grep { !$common_rank{$_} } ( 1 .. $c->end->rank-1 );
 206         }
 207
 208         # Group the variants to send to the solver
 209         my @groups;
 210         my @use_ranks;
 211         my %lacunae;
 212         my $moved = {};
 213         foreach my $rank ( @ranks ) {
 214                 my $missing = $lacunose->clone();
 215                 my $rankgroup = group_variants( $tradition, $rank, $missing, $moved, $collapse );
 216                 # Filter out any empty rankgroups
 217                 # (e.g. from the later rank for a transposition)
 218                 next unless keys %$rankgroup;
 219                 # Get the graph for this rankgroup
 220                 my $rankgraph = _graph_for_grouping( $stemma, $rankgroup, $missing, $aclabel );
 221                 if( $opts{'exclude_type1'} ) {
 222                         # Check to see whether this is a "useful" group.
 223                         next unless _useful_variant( $rankgroup, $rankgraph, $aclabel );
 224                 }
 225                 push( @use_ranks, $rank );
 226                 push( @groups, { grouping => $rankgroup, graph => $rankgraph } );
 227                 $lacunae{$rank} = $missing;
 228         }
 229         # Run the solver
 230         my $answer;
 231         try {
 232                 $answer = solve_variants( $dir, @groups );
 233         } catch ( Text::Tradition::Error $e ) {
 234                 if( $e->message =~ /IDP/ ) {
 235                         # Something is wrong with the solver; make the variants table anyway
 236                         $answer->{'variants'} = [];
 237                         map { push( @{$answer->{'variants'}}, _init_unsolved( $_, 'IDP error' ) ) }
 238                                 @groups;
 239                 } else {
 240                         # Something else is wrong; error out.
 241                         $e->throw;
 242                 }
 243         }
 244
 245         # Do further analysis on the answer
 246         my $conflict_count = 0;
 247         my $reversion_count = 0;
 248         foreach my $idx ( 0 .. $#use_ranks ) {
 249                 my $location = $answer->{'variants'}->[$idx];
 250                 # Add the rank back in
 251                 my $rank = $use_ranks[$idx];
 252                 $location->{'id'} = $rank;
 253                 # Note what our lacunae are
 254                 my %lmiss;
 255                 map { $lmiss{$_} = 1 } @{$lacunae{$use_ranks[$idx]}};
 256                 $location->{'missing'} = [ keys %lmiss ];
 257
 258                 # Run the extra analysis we need.
 259                 ## TODO We run through all the variants in this call, so
 260                 ## why not add the reading data there instead of here below?
 261                 my $graph = $groups[$idx]->{graph};
 262                 analyze_location( $tradition, $graph, $location, \%lmiss );
 263
 264                 my @layerwits;
 265                 # Do the final post-analysis tidying up of the data.
 266                 foreach my $rdghash ( @{$location->{'readings'}} ) {
 267                         $conflict_count++ if $rdghash->{'is_conflict'};
 268                         $reversion_count++ if $rdghash->{'is_reverted'};
 269                         # Add the reading text back in, setting display value as needed
 270                         my $rdg = $c->reading( $rdghash->{'readingid'} );
 271                         if( $rdg ) {
 272                                 $rdghash->{'text'} = $rdg->text .
 273                                         ( $rdg->rank == $rank ? '' : ' [' . $rdg->rank . ']' );
 274                                 if( $rdg->does( 'Text::Tradition::Morphology' ) ) {
 275                                         $rdghash->{'is_ungrammatical'} = $rdg->grammar_invalid;
 276                                         $rdghash->{'is_nonsense'} = $rdg->is_nonsense;
 277                                 }
 278                         }
 279                         # Remove lacunose witnesses from this reading's list now that the
 280                         # analysis is done
 281                         my @realgroup;
 282                         map { push( @realgroup, $_ ) unless $lmiss{$_} } @{$rdghash->{'group'}};
 283                         $rdghash->{'group'} = \@realgroup;
 284                         # Note any layered witnesses that appear in this group
 285                         foreach( @realgroup ) {
 286                                 if( $_ =~ /^(.*)\Q$aclabel\E$/ ) {
 287                                         push( @layerwits, $1 );
 288                                 }
 289                         }
 290                 }
 291                 $location->{'layerwits'} = \@layerwits if @layerwits;
 292         }
 293         $answer->{'conflict_count'} = $conflict_count;
 294         $answer->{'reversion_count'} = $reversion_count;
 295
 296         return $answer;
 297 }
 298
 299 =head2 group_variants( $tradition, $rank, $lacunose, $transposed, $merge_relationship_types )
 300
 301 Groups the variants at the given $rank of the collation, treating any
 302 relationships in the set $merge_relationship_types as equivalent.
 303 $lacunose should be a reference to an array, to which the sigla of lacunose
 304 witnesses at this rank will be appended; $transposed should be a reference
 305 to a hash, wherein the identities of transposed readings and their
 306 relatives will be stored.
 307
 308 Returns a hash $group_readings where $rdg is attested by the witnesses listed
 309 in $group_readings->{$rdg}.
 310
 311 =cut
 312
 313 # Return group_readings, groups, lacunose
 314 sub group_variants {
 315         my( $tradition, $rank, $lacunose, $transposed, $collapse ) = @_;
 316         my $c = $tradition->collation;
 317         my $aclabel = $c->ac_label;
 318         my $table = $c->alignment_table;
 319         # Get the alignment table readings
 320         my %readings_at_rank;
 321         my $check_for_gaps = Set::Scalar->new();
 322         my %moved_wits;
 323         my $has_transposition;
 324         foreach my $tablewit ( @{$table->{'alignment'}} ) {
 325                 my $rdg = $tablewit->{'tokens'}->[$rank-1];
 326                 my $wit = $tablewit->{'witness'};
 327                 # Exclude the witness if it is "lacunose" which if we got here
 328                 # means "not in the stemma".
 329                 next if _is_lacunose( $wit, $lacunose, $aclabel );
 330                 # Note if the witness is actually in a lacuna
 331                 if( $rdg && $rdg->{'t'}->is_lacuna ) {
 332                         _add_to_witlist( $wit, $lacunose, $aclabel );
 333                 # Otherwise the witness either has a positive reading...
 334                 } elsif( $rdg ) {
 335                         # If the reading has been counted elsewhere as a transposition, ignore it.
 336                         if( $transposed->{$rdg->{'t'}->id} ) {
 337                                 # TODO Does this cope with three-way transpositions?
 338                                 map { $moved_wits{$_} = 1 } @{$transposed->{$rdg->{'t'}->id}};
 339                                 next;
 340                         }
 341                         # Otherwise, record it...
 342                         $readings_at_rank{$rdg->{'t'}->id} = $rdg->{'t'};
 343                         # ...and grab any transpositions, and their relations.
 344                         my @transp = grep { $_->rank != $rank } $rdg->{'t'}->related_readings();
 345                         foreach my $trdg ( @transp ) {
 346                                 next if exists $readings_at_rank{$trdg->id};
 347                                 $has_transposition = 1;
 348                                 my @affected_wits = _table_witnesses(
 349                                         $table, $trdg, $lacunose, $aclabel );
 350                                 next unless @affected_wits;
 351                                 map { $moved_wits{$_} = 1 } @affected_wits;
 352                                 $transposed->{$trdg->id} =
 353                                         [ _table_witnesses( $table, $rdg->{'t'}, $lacunose, $aclabel ) ];
 354                                 $readings_at_rank{$trdg->id} = $trdg;
 355                         }
 356                 # ...or it is empty, ergo a gap.
 357                 } else {
 358                         _add_to_witlist( $wit, $check_for_gaps, $aclabel );
 359                 }
 360         }
 361         my $gap_wits = Set::Scalar->new();
 362         map { _add_to_witlist( $_, $gap_wits, $aclabel )
 363                 unless $moved_wits{$_} } $check_for_gaps->members;
 364
 365         # Group the readings, collapsing groups by relationship if needed.
 366         my $grouped_readings = {};
 367         foreach my $rdg ( values %readings_at_rank ) {
 368                 # Skip readings that have been collapsed into others.
 369                 next if exists $grouped_readings->{$rdg->id}
 370                         && $grouped_readings->{$rdg->id} eq 'COLLAPSE';
 371                 # Get the witness list, including from readings collapsed into this one.
 372                 my @wits = _table_witnesses( $table, $rdg, $lacunose, $aclabel );
 373                 if( $collapse && $collapse->size ) {
 374                         my $filter = sub { $collapse->has( $_[0]->type ) };
 375                         foreach my $other ( $rdg->related_readings( $filter ) ) {
 376                                 my @otherwits = _table_witnesses( $table, $other, $lacunose, $aclabel );
 377                                 push( @wits, @otherwits );
 378                                 $grouped_readings->{$other->id} = 'COLLAPSE';
 379                         }
 380                 }
 381                 $grouped_readings->{$rdg->id} = Set::Scalar->new( @wits );
 382         }
 383         if( $gap_wits->members ) {
 384                 $grouped_readings->{'(omitted)'} = $gap_wits;
 385         }
 386
 387         # Get rid of our collapsed readings
 388         map { delete $grouped_readings->{$_} if(
 389                          $grouped_readings->{$_} eq 'COLLAPSE'
 390                          || $grouped_readings->{$_}->is_empty ) }
 391                 keys %$grouped_readings;
 392
 393         # If something was transposed, check the groups for doubled-up readings
 394         if( $has_transposition ) {
 395                 # print STDERR "Group for rank $rank:\n";
 396                 # map { print STDERR "\t$_: " . join( ' ' , @{$grouped_readings->{$_}} ) . "\n" }
 397                 #       keys %$grouped_readings;
 398                 _check_transposed_consistency( $c, $rank, $transposed, $grouped_readings );
 399         }
 400
 401         # Return the result
 402         return $grouped_readings;
 403 }
 404
 405 # Helper function to query the alignment table for all witnesses (a.c. included)
 406 # that have a given reading at its rank.
 407 sub _table_witnesses {
 408         my( $table, $trdg, $lacunose, $aclabel ) = @_;
 409         my $tableidx = $trdg->rank - 1;
 410         my $has_reading = Set::Scalar->new();
 411         foreach my $row ( @{$table->{'alignment'}} ) {
 412                 my $wit = $row->{'witness'};
 413                 next if _is_lacunose( $wit, $lacunose, $aclabel );
 414                 my $rdg = $row->{'tokens'}->[$tableidx];
 415                 next unless exists $rdg->{'t'} && defined $rdg->{'t'};
 416                 _add_to_witlist( $wit, $has_reading, $aclabel )
 417                         if $rdg->{'t'}->id eq $trdg->id;
 418         }
 419         return $has_reading->members;
 420 }
 421
 422 # Helper function to see if a witness is lacunose even if we are asking about
 423 # the a.c. version
 424 sub _is_lacunose {
 425         my ( $wit, $lac, $acstr ) = @_;
 426         if( $wit =~ /^(.*)\Q$acstr\E$/ ) {
 427                 $wit = $1;
 428         }
 429         return $lac->has( $wit );
 430 }
 431
 432 # Helper function to ensure that X and X a.c. never appear in the same list.
 433 sub _add_to_witlist {
 434         my( $wit, $list, $acstr ) = @_;
 435         if( $wit =~ /^(.*)\Q$acstr\E$/ ) {
 436                 # Don't add X a.c. if we already have X
 437                 return if $list->has( $1 );
 438         } else {
 439                 # Delete X a.c. if we are about to add X
 440                 $list->delete( $wit.$acstr );
 441         }
 442         $list->insert( $wit );
 443 }
 444
 445 sub _check_transposed_consistency {
 446         my( $c, $rank, $transposed, $groupings ) = @_;
 447         my %seen_wits;
 448         my %thisrank;
 449         # Note which readings are actually at this rank, and which witnesses
 450         # belong to which reading.
 451         foreach my $rdg ( keys %$groupings ) {
 452                 my $rdgobj = $c->reading( $rdg );
 453                 # Count '(omitted)' as a reading at this rank
 454                 $thisrank{$rdg} = 1 if !$rdgobj || $rdgobj->rank == $rank;
 455                 map { push( @{$seen_wits{$_}}, $rdg ) } @{$groupings->{$rdg}};
 456         }
 457         # Our work is done if we have no witness belonging to more than one
 458         # reading.
 459         my @doubled = grep { scalar @{$seen_wits{$_}} > 1 } keys %seen_wits;
 460         return unless @doubled;
 461         # If we have a symmetric related transposition, drop the non-rank readings.
 462         if( @doubled == scalar keys %seen_wits ) {
 463                 foreach my $rdg ( keys %$groupings ) {
 464                         if( !$thisrank{$rdg} ) {
 465                                 my $groupstr = wit_stringify( $groupings->{$rdg} );
 466                                 my ( $matched ) = grep { $groupstr eq wit_stringify( $groupings->{$_} ) }
 467                                         keys %thisrank;
 468                                 delete $groupings->{$rdg};
 469                                 # If we found a group match, assume there is a symmetry happening.
 470                                 # TODO think more about this
 471                                 # print STDERR "*** Deleting symmetric reading $rdg\n";
 472                                 unless( $matched ) {
 473                                         delete $transposed->{$rdg};
 474                                         warn "Found problem in evident symmetry with reading $rdg";
 475                                 }
 476                         }
 477                 }
 478         # Otherwise 'unhook' the transposed reading(s) that have duplicates.
 479         } else {
 480                 foreach my $dup ( @doubled ) {
 481                         foreach my $rdg ( @{$seen_wits{$dup}} ) {
 482                                 next if $thisrank{$rdg};
 483                                 next unless exists $groupings->{$rdg};
 484                                 # print STDERR "*** Deleting asymmetric doubled-up reading $rdg\n";
 485                                 delete $groupings->{$rdg};
 486                                 delete $transposed->{$rdg};
 487                         }
 488                 }
 489                 # and put any now-orphaned readings into an 'omitted' reading.
 490                 foreach my $wit ( keys %seen_wits ) {
 491                         unless( grep { exists $groupings->{$_} } @{$seen_wits{$wit}} ) {
 492                                 $groupings->{'(omitted)'} = Set::Scalar->new()
 493                                          unless exists $groupings->{'(omitted)'};
 494                                 _add_to_witlist( $wit, $groupings->{'(omitted)'}, $c->ac_label );
 495                         }
 496                 }
 497         }
 498 }
 499
 500 # For the given grouping, return its situation graph based on the stemma.
 501 sub _graph_for_grouping {
 502         my( $stemma, $grouping, $lacunose, $aclabel ) = @_;
 503         my $acwits = [];
 504         my $extant = {};
 505         foreach my $gs ( values %$grouping ) {
 506                 map {
 507                         if( $_ =~ /^(.*)\Q$aclabel\E$/ ) {
 508                                 push( @$acwits, $1 ) unless $lacunose->has( $1 );
 509                         } else {
 510                                 $extant->{$_} = 1 unless $lacunose->has( $_ );
 511                         }
 512                 } $gs->members;
 513         }
 514         my $graph;
 515         try {
 516                 # contig contains all extant wits and all hypothetical wits
 517                 # needed to make up the groups.
 518                 $graph = $stemma->situation_graph( $extant, $acwits, $aclabel );
 519         } catch ( Text::Tradition::Error $e ) {
 520                 throw( "Could not extend graph with given extant and a.c. witnesses: "
 521                         . $e->message );
 522         } catch {
 523                 throw( "Could not extend graph with a.c. witnesses @$acwits" );
 524         }
 525         return $graph;
 526 }
 527
 528 =head2 solve_variants( $calcdir, @groups )
 529
 530 Looks up the set of groups in the answers provided by the external graph solver
 531 service and returns a cleaned-up answer, adding the rank IDs back where they belong.
 532
 533 The answer has the form
 534   { "variants" => [ array of variant location structures ],
 535     "variant_count" => total,
 536     "conflict_count" => number of conflicts detected,
 537     "genealogical_count" => number of solutions found }
 538
 539 =cut
 540
 541 sub solve_variants {
 542         my( @groups ) = @_;
 543
 544         # Are we using a local result directory, or did we pass an empty value
 545         # for the directory?
 546         my $dir;
 547         unless( ref( $groups[0] ) eq 'HASH' ) {
 548                 $dir = shift @groups;
 549         }
 550
 551         ## For each graph/group combo, make a Text::Tradition::Analysis::Result
 552         ## object so that we can send it off for IDP lookup.
 553         my $variants = [];
 554         my $genealogical = 0; # counter
 555         # TODO Optimize for unique graph problems
 556         my %problems;
 557         foreach my $graphproblem ( @groups ) {
 558                 # Construct the calc result key and look up its answer
 559                 my $problem = Text::Tradition::Analysis::Result->new(
 560                         graph => $graphproblem->{'graph'},
 561                         setlist => [ values %{$graphproblem->{'grouping'}} ] );
 562                 if( exists $problems{$problem->object_key} ) {
 563                         $problem = $problems{$problem->object_key};
 564                 } else {
 565                         $problems{$problem->object_key} = $problem;
 566                 }
 567                 $graphproblem->{'object'} = $problem;
 568         }
 569
 570         my %results;
 571         if( $dir ) {
 572                 my $scope = $dir->new_scope;
 573                 map { $results{$_} = $dir->lookup( $_ ) || $problems{$_} } keys %problems;
 574         } else {
 575                 my $json = JSON->new->allow_blessed->convert_blessed->utf8->encode(
 576                         [ values %problems ] );
 577                 # Send it off and get the result
 578                 # print STDERR "Sending request: " . decode_utf8( $json ) . "\n";
 579                 my $ua = LWP::UserAgent->new();
 580                 my $resp = $ua->post( $SOLVER_URL, 'Content-Type' => 'application/json',
 581                                                           'Content' => $json );
 582                 my $answer;
 583                 if( $resp->is_success ) {
 584                         $answer = decode_json( $resp->content );
 585                         throw( "Unexpected answer from IDP: $answer" ) unless ref( $answer ) eq 'ARRAY';
 586                 } else {
 587                         throw( "IDP solver returned " . $resp->status_line . " / " . $resp->content
 588                                 . "; cannot run graph analysis" );
 589                 }
 590                 # One more sanity check
 591                 throw( "Something went wrong with answer symmetricity" )
 592                         unless keys( %problems ) == @$answer;
 593                 # Convert the results
 594                 foreach my $a ( @$answer ) {
 595                         my $r = Text::Tradition::Analysis::Result->new( $a );
 596                         $results{$r->object_key} = $r;
 597                 }
 598         }
 599
 600         # We now have a single JSON-encoded Result object per problem sent. Fold its
 601         # answers into our variant info structure.
 602         foreach my $graphproblem ( @groups ) {
 603                 my $result = $results{$graphproblem->{'object'}->object_key}
 604                         || $graphproblem->{'object'};
 605
 606                 # Initialize the result structure for this graph problem
 607                 my $vstruct;
 608                 if( $result->status eq 'OK' ) {
 609                         $vstruct = { readings => [] };
 610                         push( @$variants, $vstruct );
 611                 } else {
 612                         push( @$variants, _init_unsolved( $graphproblem, $result->status ) );
 613                         next;
 614                 }
 615
 616                 # 1. Did the group evaluate as genealogical?
 617                 $vstruct->{genealogical} = $result->is_genealogical;
 618                 $genealogical++ if $result->is_genealogical;
 619
 620                 # 2. What are the calculated minimum groupings for each variant loc?
 621                 foreach my $rid ( keys %{$graphproblem->{grouping}} ) {
 622                         my $inputset = $graphproblem->{grouping}->{$rid};
 623                         my $minset = $result->minimum_grouping_for( $inputset );
 624                         push( @{$vstruct->{readings}}, { readingid => $rid, group => $minset } );
 625                 }
 626
 627                 # 3. What are the sources and classes calculated for each witness?
 628                 $vstruct->{witcopy_types} = { $result->classes };
 629                 $vstruct->{reading_roots} = {};
 630                 map { $vstruct->{reading_roots}->{$_} = 1 } $result->sources;
 631
 632         }
 633
 634         return { 'variants' => $variants,
 635                          'variant_count' => scalar @$variants,
 636                          'genealogical_count' => $genealogical };
 637 }
 638
 639 sub _init_unsolved {
 640         my( $graphproblem, $status ) = @_;
 641         my $vstruct = { 'readings' => [] };
 642         $vstruct->{'unsolved'} = $status;
 643         foreach my $rid ( keys %{$graphproblem->{grouping}} ) {
 644                 push( @{$vstruct->{readings}}, { readingid => $rid,
 645                         group => [ $graphproblem->{grouping}->{$rid}->members ] } );
 646         }
 647         return $vstruct;
 648 }
 649
 650 =head2 analyze_location ( $tradition, $graph, $location_hash )
 651
 652 Given the tradition, its stemma graph, and the solution from the graph solver,
 653 work out the rest of the information we want.  For each reading we need missing,
 654 conflict, reading_parents, independent_occurrence, followed, not_followed,
 655 and follow_unknown.  Alters the location_hash in place.
 656
 657 =cut
 658
 659 sub analyze_location {
 660         my ( $tradition, $graph, $variant_row, $lacunose ) = @_;
 661         my $c = $tradition->collation;
 662
 663         if( exists $variant_row->{'unsolved'} ) {
 664                 return;
 665         }
 666         my $reading_roots = delete $variant_row->{'reading_roots'};
 667         my $classinfo = delete $variant_row->{'witcopy_types'};
 668
 669         # Make a hash of all known node memberships, and make the subgraphs.
 670         my $contig = {};
 671         my $subgraph = {};
 672         my $acstr = $c->ac_label;
 673         my @acwits;
 674
 675         # Note which witnesses positively belong to which group. This information
 676         # comes ultimately from the IDP solver.
 677         # Also make a note of the reading's roots.
 678     foreach my $rdghash ( @{$variant_row->{'readings'}} ) {
 679         my $rid = $rdghash->{'readingid'};
 680         my @roots;
 681         foreach my $wit ( @{$rdghash->{'group'}} ) {
 682                 $contig->{$wit} = $rid;
 683             if( $wit =~ /^(.*)\Q$acstr\E$/ ) {
 684                 push( @acwits, $1 );
 685             }
 686             if( exists $reading_roots->{$wit} && $reading_roots->{$wit} ) {
 687                 push( @roots, $wit );
 688             }
 689         }
 690                 $rdghash->{'independent_occurrence'} = \@roots;
 691         }
 692
 693         # Now that we have all the node group memberships, calculate followed/
 694     # non-followed/unknown values for each reading.  Also figure out the
 695     # reading's evident parent(s).
 696     foreach my $rdghash ( @{$variant_row->{'readings'}} ) {
 697         my $rid = $rdghash->{'readingid'};
 698         my $rdg = $c->reading( $rid );
 699         my @roots = @{$rdghash->{'independent_occurrence'}};
 700         my @reversions;
 701         if( $classinfo ) {
 702                 @reversions = grep { $classinfo->{$_} eq 'revert' }
 703                         $rdghash->{'group'}->members;
 704                 $rdghash->{'reversions'} = \@reversions;
 705         }
 706         my @group = @{$rdghash->{'group'}};
 707
 708         # Start figuring things out.
 709         $rdghash->{'followed'} = scalar( @group )
 710                 - ( scalar( @roots ) + scalar( @reversions ) );
 711         # Find the parent readings, if any, of this reading.
 712         my $sourceparents = _find_reading_parents( $rid, $graph, $contig, @roots );
 713                 # Work out relationships between readings and their non-followed parent.
 714                 _resolve_parent_relationships( $c, $rid, $rdg, $sourceparents );
 715                 $rdghash->{'source_parents'} = $sourceparents;
 716
 717                 if( @reversions ) {
 718                         my $revparents = _find_reading_parents( $rid, $graph, $contig, @reversions );
 719                         _resolve_parent_relationships( $c, $rid, $rdg, $revparents );
 720                         $rdghash->{'reversion_parents'} = $revparents;
 721                 }
 722
 723                 # Find the number of times this reading was altered, and the number of
 724                 # times we're not sure.
 725                 my( %nofollow, %unknownfollow );
 726                 foreach my $wit ( @{$rdghash->{'group'}} ) {
 727                         foreach my $wchild ( $graph->successors( $wit ) ) {
 728                                 if( $reading_roots->{$wchild} && $contig->{$wchild}
 729                                         && $contig->{$wchild} ne $rid ) {
 730                                         # It definitely changed here.
 731                                         $nofollow{$wchild} = 1;
 732                                 } elsif( !($contig->{$wchild}) ) {
 733                                         # The child is a hypothetical node not definitely in
 734                                         # any group. Answer is unknown.
 735                                         $unknownfollow{$wchild} = 1;
 736                                 } # else it is either in our group, or it is a non-root node in a
 737                                   # known group and therefore is presumed to have its reading from
 738                                   # its group, not this link.
 739                         }
 740                 }
 741                 $rdghash->{'not_followed'} = keys %nofollow;
 742                 $rdghash->{'follow_unknown'} = keys %unknownfollow;
 743
 744                 # Now say whether this reading represents a conflict.
 745                 unless( $variant_row->{'genealogical'} ) {
 746                         $rdghash->{'is_conflict'} = @roots != 1;
 747                         $rdghash->{'is_reverted'} = scalar @reversions;
 748                 }
 749     }
 750 }
 751
 752 sub _find_reading_parents {
 753         my( $rid, $graph, $contig, @list ) = @_;
 754         my $parenthash = {};
 755         foreach my $wit ( @list ) {
 756                 # Look in the stemma graph to find this witness's extant or known-reading
 757                 # immediate ancestor(s), and look up the reading that each ancestor holds.
 758                 my @check = $graph->predecessors( $wit );
 759                 while( @check ) {
 760                         my @next;
 761                         foreach my $wparent( @check ) {
 762                                 my $preading = $contig->{$wparent};
 763                                 if( $preading && $preading ne $rid ) {
 764                                         $parenthash->{$preading} = 1;
 765                                 } else {
 766                                         push( @next, $graph->predecessors( $wparent ) );
 767                                 }
 768                         }
 769                         @check = @next;
 770                 }
 771         }
 772         return $parenthash;
 773 }
 774
 775 sub _resolve_parent_relationships {
 776         my( $c, $rid, $rdg, $rdgparents ) = @_;
 777         foreach my $p ( keys %$rdgparents ) {
 778                 # Resolve the relationship of the parent to the reading, and
 779                 # save it in our hash.
 780                 my $pobj = $c->reading( $p );
 781                 my $prep = $pobj ? $pobj->id . ' (' . $pobj->text . ')' : $p;
 782                 my $phash = { 'label' => $prep };
 783                 if( $pobj ) {
 784                         my $rel = $c->get_relationship( $p, $rid );
 785                         if( $rel ) {
 786                                 _add_to_hash( $rel, $phash );
 787                         } elsif( $rdg ) {
 788                                 # First check for a transposed relationship
 789                                 if( $rdg->rank != $pobj->rank ) {
 790                                         foreach my $ti ( $rdg->related_readings( 'transposition' ) ) {
 791                                                 next unless $ti->text eq $rdg->text;
 792                                                 $rel = $c->get_relationship( $ti, $pobj );
 793                                                 if( $rel ) {
 794                                                         _add_to_hash( $rel, $phash, 1 );
 795                                                         last;
 796                                                 }
 797                                         }
 798                                         unless( $rel ) {
 799                                                 foreach my $ti ( $pobj->related_readings( 'transposition' ) ) {
 800                                                         next unless $ti->text eq $pobj->text;
 801                                                         $rel = $c->get_relationship( $ti, $rdg );
 802                                                         if( $rel ) {
 803                                                                 _add_to_hash( $rel, $phash, 1 );
 804                                                                 last;
 805                                                         }
 806                                                 }
 807                                         }
 808                                 }
 809                                 unless( $rel ) {
 810                                         # and then check for sheer word similarity.
 811                                         my $rtext = $rdg->text;
 812                                         my $ptext = $pobj->text;
 813                                         if( similar( $rtext, $ptext ) ) {
 814                                                 # say STDERR "Words $rtext and $ptext judged similar";
 815                                                 $phash->{relation} = { type => 'wordsimilar' };
 816                                         }
 817                                 }
 818                         } else {
 819                                 $phash->{relation} = { type => 'deletion' };
 820                         }
 821                         # Get the attributes of the parent object while we are here
 822                         $phash->{'text'} = $pobj->text if $pobj;
 823                         if( $pobj && $pobj->does('Text::Tradition::Morphology') ) {
 824                                 $phash->{'is_nonsense'} = $pobj->is_nonsense;
 825                                 $phash->{'is_ungrammatical'} = $pobj->grammar_invalid;
 826                         }
 827                 } elsif( $p eq '(omitted)' ) {
 828                         $phash->{relation} = { type => 'addition' };
 829                 }
 830                 # Save it
 831                 $rdgparents->{$p} = $phash;
 832         }
 833 }
 834
 835 sub _add_to_hash {
 836         my( $rel, $phash, $is_transposed ) = @_;
 837         $phash->{relation} = { type => $rel->type };
 838         $phash->{relation}->{transposed} = 1 if $is_transposed;
 839         $phash->{relation}->{annotation} = $rel->annotation
 840                 if $rel->has_annotation;
 841 }
 842
 843 =head2 similar( $word1, $word2 )
 844
 845 Use Algorithm::Diff to get a sense of how close the words are to each other.
 846 This will hopefully handle substitutions a bit more nicely than Levenshtein.
 847
 848 =cut
 849
 850 #!/usr/bin/env perl
 851
 852 sub similar {
 853         my( $word1, $word2 ) = sort { length($a) <=> length($b) } @_;
 854         my @let1 = split( '', lc( $word1 ) );
 855         my @let2 = split( '', lc( $word2 ) );
 856         my $diff = Algorithm::Diff->new( \@let1, \@let2 );
 857         my $mag = 0;
 858         while( $diff->Next ) {
 859                 if( $diff->Same ) {
 860                         # Take off points for longer strings
 861                         my $cs = $diff->Range(1) - 2;
 862                         $cs = 0 if $cs < 0;
 863                         $mag -= $cs;
 864                 } elsif( !$diff->Items(1) ) {
 865                         $mag += $diff->Range(2);
 866                 } elsif( !$diff->Items(2) ) {
 867                         $mag += $diff->Range(1);
 868                 } else {
 869                         # Split the difference for substitutions
 870                         my $c1 = $diff->Range(1) || 1;
 871                         my $c2 = $diff->Range(2) || 1;
 872                         my $cd = ( $c1 + $c2 ) / 2;
 873                         $mag += $cd;
 874                 }
 875         }
 876         return ( $mag <= length( $word1 ) / 2 );
 877 }
 878
 879 sub _useful_variant {
 880         my( $rankgroup, $rankgraph, $acstr ) = @_;
 881
 882         # Sort by group size and return
 883         my $is_useful = 0;
 884         foreach my $rdg ( keys %$rankgroup ) {
 885                 my @wits = $rankgroup->{$rdg}->members;
 886                 if( @wits > 1 ) {
 887                         $is_useful++;
 888                 } else {
 889                         $is_useful++ unless( $rankgraph->is_sink_vertex( $wits[0] )
 890                                 || $wits[0] =~ /\Q$acstr\E$/ );
 891                 }
 892         }
 893         return $is_useful > 1;
 894 }
 895
 896 =head2 wit_stringify( $groups )
 897
 898 Takes an array of witness groupings and produces a string like
 899 ['A','B'] / ['C','D','E'] / ['F']
 900
 901 =cut
 902
 903 sub wit_stringify {
 904     my $groups = shift;
 905     my @gst;
 906     # If we were passed an array of witnesses instead of an array of
 907     # groupings, then "group" the witnesses first.
 908     unless( ref( $groups->[0] ) ) {
 909         my $mkgrp = [ $groups ];
 910         $groups = $mkgrp;
 911     }
 912     foreach my $g ( @$groups ) {
 913         push( @gst, '[' . join( ',', map { "'$_'" } @$g ) . ']' );
 914     }
 915     return join( ' / ', @gst );
 916 }
 917
 918 1;
 919
 920 sub throw {
 921         Text::Tradition::Error->throw(
 922                 'ident' => 'Analysis error',
 923                 'message' => $_[0],
 924         );
 925 }
 926
 927 =head1 LICENSE
 928
 929 This package is free software and is provided "as is" without express
 930 or implied warranty.  You can redistribute it and/or modify it under
 931 the same terms as Perl itself.
 932
 933 =head1 AUTHOR
 934
 935 Tara L Andrews E<lt>aurum@cpan.orgE<gt>