lib/Text/Tradition/Analysis/Result.pm

   1 package Text::Tradition::Analysis::Result;
   2
   3 use Moose;
   4 use Digest::MD5 qw/ md5_hex /;
   5 use Encode qw/ encode_utf8 /;
   6 use JSON qw/ to_json /;
   7 use Set::Scalar;
   8 use Text::Tradition::Error;
   9
  10 =head1 NAME
  11
  12 Text::Tradition::Analysis::Result - object to express an IDP calculation result
  13 for a particular graph problem.
  14
  15 =head1 DESCRIPTION
  16
  17 Given a graph (expressing a stemma hypothesis) and a set of witness groupings
  18 (expressing variation in reading between witnesses related according to the
  19 stemma hypothesis), it is possible to calculate certain properties of how the
  20 readings might be related to each other. This calculation depends on a custom
  21 program run under the IDP system [TODO URL]. As the problem is NP-hard, the
  22 calculation can take a long time. The purpose of this object is to allow storage
  23 of calculated results in a database.
  24
  25 For each graph problem, the following features can be calculated:
  26
  27 =over 4
  28
  29 =item * Whether the reading groups form a genealogical pattern on the stemma.
  30
  31 =item * The groupings, including lost/hypothetical witnesses if necessary, that minimize the amount of non-genealogical variation on the stemma.
  32
  33 =item * The classes, which for each witness express whether (in a minimally non-genealogical case) the witness is a source of its reading, follows a parent witness, or reverts to an ancestral reading that is not the parent's.
  34
  35 =back
  36
  37 =head1 CONSTRUCTOR
  38
  39 =head2 new
  40
  41 Creates a new graph problem. Requires two properties:
  42
  43 =over 4
  44
  45 =item * setlist - An array of arrays expressing the witness sets. The inner
  46 arrays will be converted to Set::Scalar objects, and must have distinct members.
  47
  48 =item * graph - A dot description of a graph (e.g. the output of a call to
  49 Text::Tradition::Stemma::editable) against which the sets will be analyzed.
  50
  51 =back
  52
  53 All other properties should be calculated by IDP rather than set manually.
  54 These include:
  55
  56 =over 4
  57
  58 =item * is_genealogical - Boolean, indicating whether the witness sets form
  59 genealogical groupings on the graph.
  60
  61 =item * status - String to indicate whether a solution has been calculated
  62 for this analysis problem. Recognized values are "OK" (calculated) and
  63 "running" (being calculated now). All other values, or no value, imply that
  64 the calculation has yet to take place.
  65
  66 =item * groupings - These are extended (if necessary) versions of the witness
  67 sets, which include the hypothetical witnesses necessary to minimize coincidence
  68 of variation.
  69
  70 =item * classes - These are key/value pairs, keyed by witness, indicating for
  71 each witness whether it is the source of a reading variant, whether it represents
  72 a reversion to an ancestor (but not parent) reading, or whether its reading
  73 follows that of a parent on the graph.
  74
  75 =back
  76
  77 =begin testing
  78
  79 use Test::More::UTF8;
  80 use Text::Tradition;
  81 use TryCatch;
  82 use_ok( 'Text::Tradition::Analysis::Result' );
  83
  84 # Make a problem with a graph and a set of groupings
  85
  86 my $datafile = 't/data/florilegium_tei_ps.xml';
  87 my $tradition = Text::Tradition->new( 'input' => 'TEI',
  88                                       'name' => 'flortest',
  89                                       'file' => $datafile );
  90 my $s = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
  91
  92 my $sets = [ [ qw/ D Q / ], [ qw/ F H / ], [ qw/ A B C P S T / ] ];
  93 my $extant = {};
  94 foreach my $set ( @$sets ) {
  95         map { $extant->{$_} = 1 } @$set;
  96 }
  97 my $sitgraph = $s->editable( { extant => $extant } );
  98 my $result = Text::Tradition::Analysis::Result->new(
  99         graph => $sitgraph,
 100         setlist => $sets );
 101 is( ref( $result ), 'Text::Tradition::Analysis::Result', "Got a Result object" );
 102 is( $result->graph, $sitgraph, "Got identical graph string back" );
 103 is( $result->status, "new", "Calculation status of result set correctly" );
 104 my @rsets = $result->sets;
 105 is( $rsets[0], '(A B C P S T)', "First set is biggest set" );
 106 is( $rsets[1], '(D Q)', "Second set is by alphabetical order" );
 107 is( $rsets[2], '(F H)', "Second set is by alphabetical order" );
 108
 109 # Add some calculation values
 110 $result->is_genealogical( 1 );
 111 $result->record_grouping( [ qw/ 4 5 D Q / ] );
 112 try {
 113         $result->record_grouping( [ qw/ 3 4 D H / ] );
 114         ok( 0, "Recorded a grouping that does not match the input sets" );
 115 } catch ( Text::Tradition::Error $e ) {
 116         like( $e->message, qr/Failed to find witness set that is a subset of/,
 117                 "Correct error thrown on bad record_grouping attempt" );
 118 }
 119 $result->record_grouping( [ qw/ 3 F H / ] );
 120 my $gp1 = $result->grouping(1);
 121 is( $result->minimum_grouping_for( $rsets[1] ), $gp1,
 122         "Found a minimum grouping for D Q" );
 123 is( "$gp1", "(4 5 D Q)", "Retrieved minimum grouping is correct" );
 124 is( $result->minimum_grouping_for( $rsets[0] ), $rsets[0],
 125         "Default minimum grouping found for biggest group" );
 126 $result->record_grouping( [ qw/ 1 α δ A B C P S T / ] );
 127 my %classes = (
 128         α => 'source',
 129         3 => 'source',
 130         4 => 'source' );
 131 foreach my $gp ( $result->groupings ) {
 132         map { my $c = $classes{$_} || 'copy'; $result->set_class( $_, $c ) } @$gp;
 133 }
 134 foreach my $gp ( $result->groupings ) {
 135         foreach my $wit ( @$gp ) {
 136                 my $expected = $classes{$wit} || 'copy';
 137                 is( $result->class( $wit ), $expected, "Got expected witness class for $wit" );
 138         }
 139 }
 140
 141 # Now write it out to JSON
 142 my $struct = $result->TO_JSON;
 143 my $newresult = Text::Tradition::Analysis::Result->new( $struct );
 144 is( $result->object_key, $newresult->object_key,
 145         "Object key stayed constant on export/import" );
 146 my $problem = Text::Tradition::Analysis::Result->new( graph => $sitgraph, setlist => $sets );
 147 is( $problem->object_key, $result->object_key,
 148         "Object key stayed constant for newly created problem" );
 149
 150
 151 =end testing
 152
 153 =head1 METHODS
 154
 155 =head2 $self->has_class( $witness )
 156 =head2 $self->class( $witness )
 157
 158 If a class has been calculated for the given witness, has_class returns true
 159 and class returns the calculated answer.
 160
 161 =cut
 162
 163 has 'setlist' => (
 164         traits => ['Array'],
 165         isa => 'ArrayRef[Set::Scalar]',
 166         handles => {
 167                 sets => 'elements',
 168                 set_index => 'first_index',
 169         },
 170         required => 1
 171 );
 172
 173 has 'graph' => (
 174         is => 'ro',
 175         isa => 'Str',
 176         required => 1
 177 );
 178
 179 has 'status' => (
 180         is => 'rw',
 181         isa => 'Str'
 182 );
 183
 184 has 'is_genealogical' => (
 185         is => 'rw',
 186         isa => 'Bool',
 187         predicate => 'has_genealogical_result'
 188 );
 189
 190 has 'groupinglist' => (
 191         traits => ['Array'],
 192         isa => 'ArrayRef[Set::Scalar]',
 193         handles => {
 194                 groupings => 'elements',
 195                 _add_grouping => 'push',
 196                 _set_grouping => 'set',
 197                 grouping => 'get',
 198         },
 199         default => sub { [] }
 200 );
 201
 202 has 'classlist' => (
 203         traits => ['Hash'],
 204         isa => 'HashRef[Str]',
 205         handles => {
 206                 class => 'get',
 207                 has_class => 'exists',
 208                 set_class => 'set',
 209                 classes => 'elements',
 210                 assigned_wits => 'keys',
 211         },
 212 );
 213
 214 around BUILDARGS => sub {
 215         my $orig = shift;
 216         my $class = shift;
 217         my $args = @_ == 1 ? $_[0] : { @_ };
 218
 219         # Convert the set list into a list of Set::Scalars, ordered first by size and
 220         # then alphabetically by first-sorted.
 221         die "Must specify a set list to Analysis::Result->new()"
 222                 unless ref( $args->{'setlist'} ) eq 'ARRAY';
 223         # Order the sets and make sure they are all distinct Set::Scalars.
 224         $args->{'setlist'} = [ sort { by_size_and_alpha( $a, $b ) }
 225                                                         _check_set_args( $args->{'setlist'} ) ];
 226         if( exists $args->{'groupinglist'} ) {
 227                 $args->{'groupinglist'} = [ _check_set_args( $args->{'groupinglist'} ) ];
 228         }
 229
 230         # If we have been passed a Text::Tradition::Stemma or a Graph, save only
 231         # its string.
 232         if( ref( $args->{'graph'} ) ) {
 233                 my $st = delete $args->{'graph'};
 234                 my $type = ref( $st );
 235                 my $gopt = { linesep => ' ' };
 236                 if( $type eq 'Text::Tradition::Stemma' ) {
 237                         $args->{'graph'} = $st->editable( $gopt );
 238                 } elsif( $type eq 'Graph' ) {
 239                         $args->{'graph'} = Text::Tradition::Stemma::editable_graph( $st, $gopt );
 240                 } else {
 241                         die "Passed argument to graph that is neither Stemma nor Graph";
 242                 }
 243         }
 244
 245         # If our only args are graph and setlist, then status should be 'new'
 246         $DB::single = 1;
 247         if( scalar keys %$args == 2 ) {
 248                 $args->{'status'} = 'new';
 249         }
 250
 251         return $class->$orig( $args );
 252 };
 253
 254 sub _check_set_args {
 255         my $setlist = shift;
 256         my @sets;
 257         foreach my $set ( @{$setlist} ) {
 258                 my $s = $set;
 259                 # Check uniqueness of the current set
 260                 if( ref( $set ) ne 'Set::Scalar' ) {
 261                         $s = Set::Scalar->new( @$set );
 262                         die "Duplicate element(s) in set or group passed to Analysis::Result->new()"
 263                                 unless @$set == $s->elements;
 264                 }
 265                 # Check distinctness of the set from all other sets given so far
 266                 foreach my $ps ( @sets ) {
 267                         die "Two sets are not disjoint"
 268                                 unless $s->is_disjoint( $ps );
 269                 }
 270                 # Save the set.
 271                 push( @sets, $s );
 272         }
 273         return @sets;
 274 }
 275
 276 sub BUILD {
 277         my $self = shift;
 278
 279         # Initialize the groupings array
 280         map { $self->_add_grouping( $_ ) } $self->sets;
 281 }
 282
 283 =head2 $self->object_key
 284
 285 Returns a unique key that can be used to look up this graph/set combination in
 286 a database. Currently an MD5 hash of the request_string.
 287
 288 =cut
 289
 290 sub object_key {
 291         my $self = shift;
 292         return md5_hex( encode_utf8( $self->request_string ) );
 293 }
 294
 295 =head2 $self->request_string
 296
 297 A request string is the graph followed by the groups, which should form a unique
 298 key for the result.
 299
 300 =cut
 301
 302 sub request_string {
 303         my $self = shift;
 304         return string_from_graph_problem( $self->graph, [ $self->sets ] );
 305 }
 306
 307 # TODO do we need this now?
 308
 309 sub string_from_graph_problem {
 310         my( $graph, $grouping ) = @_;
 311         my( $graphstr, @groupsets );
 312         # Get the graph string
 313         if( ref( $graph ) && ref( $graph ) eq 'Graph' ) {
 314                 $graphstr = Text::Tradition::Stemma::editable_graph( $graph, { 'linesep' => ' ' } );
 315         } else {
 316                 throw( "Passed non-graph object $graph to stringification" )
 317                         if ref( $graph );
 318                 $graphstr = $graph;
 319         }
 320         # Make sure all groupings are sets
 321         foreach my $g ( @$grouping ) {
 322                 if( ref( $g ) eq 'ARRAY' ) {
 323                         push( @groupsets, Set::Scalar->new( @$g ) );
 324                 } elsif( ref( $g ) eq 'Set::Scalar' ) {
 325                         push( @groupsets, $g );
 326                 } else {
 327                         throw( "Tried to stringify grouping $g that is neither set nor array" );
 328                 }
 329         }
 330         return $graphstr . '//' .
 331                 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
 332 }
 333
 334 # TODO do we need this?
 335 # This should work as $self->problem_json or as problem_json( @objects )
 336 sub problem_json {
 337         my( @objects ) = @_;
 338         # There should be a distinct problem for each unique graph.
 339         my %distinct_problems;
 340         foreach my $o ( @objects ) {
 341                 unless( exists $distinct_problems{$o->graph} ) {
 342                         $distinct_problems{$o->graph} = [];
 343                 }
 344                 my @groupings;
 345                 map { push( @groupings, [ $_->members ] ) } $o->sets;
 346                 push( @{$distinct_problems{$o->graph}}, \@groupings );
 347         }
 348         my @pstrs = map { to_json(
 349                 { graph => $_, groupings => $distinct_problems{$_} } ) }
 350                 keys %distinct_problems;
 351         return @pstrs;
 352 }
 353
 354 =head2 by_size_and_alpha
 355
 356 A useful utility function to sort Set::Scalar objects first in descending
 357 order by size, then in ascending alphabetical order by first element (i.e.
 358 by stringification.)
 359
 360 =cut
 361
 362 sub by_size_and_alpha {
 363         my( $a, $b ) = @_;
 364         my $size = $b->members <=> $a->members;
 365         return $size if $size;
 366         # Then sort by alphabetical order of set elements.
 367         return "$a" cmp "$b";
 368 }
 369
 370 =head2 $self->sources
 371
 372 Return all 'source' class witnesses in these sets for this graph.
 373
 374 =cut
 375
 376 sub sources {
 377         my $self = shift;
 378         my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
 379         return @sources;
 380 }
 381
 382 =head2 $self->minimum_grouping_for( $set )
 383
 384 Return the minimum grouping (including necessary hypothetical witnesses) for
 385 the witness set specified. Will return undef if $set does not match one of
 386 the defined witness sets in $self->sets.
 387
 388 =cut
 389
 390 # Look for a matching set in our setlist, and return its corresponding group
 391 sub minimum_grouping_for {
 392         my( $self, $set ) = @_;
 393         my $midx = $self->set_index( sub { "$set" eq "$_" } );
 394         return undef unless defined $midx;
 395         return $self->grouping( $midx );
 396 }
 397
 398 =head1 CALCULATION STORAGE METHODS
 399
 400 =head2 $self->is_genealogical( $bool )
 401
 402 Record that the sets are genealogical for this graph.
 403
 404 =head2 $self->set_class( $witness, $class )
 405
 406 Record that the witness in question is of the given class.
 407
 408 =head2 $self->record_grouping( $group )
 409
 410 Record that the group in question (either an arrayref or a Set::Scalar) forms
 411 a minimum grouping on the graph. Will throw an error unless the group is a
 412 (non-proper) superset of an existing witness set.
 413
 414 =cut
 415
 416 sub record_grouping {
 417         my( $self, $group ) = @_;
 418         unless( ref( $group ) eq 'Set::Scalar' ) {
 419                 my $s = Set::Scalar->new( @$group );
 420                 $group = $s;
 421         }
 422         # Find the set that is a subset of this group, and record it in the
 423         # correct spot in our groupinglist.
 424         my $idx = 0;
 425         foreach my $set ( $self->sets ) {
 426                 if( _is_subset( $set, $group ) ) {
 427                         $self->_set_grouping( $idx, $group );
 428                         last;
 429                 }
 430                 $idx++;
 431         }
 432         if( $idx == scalar( $self->sets ) ) {
 433                 throw( "Failed to find witness set that is a subset of $group" );
 434         }
 435 }
 436
 437 sub _is_subset {
 438     # A replacement for the stupid Set::Scalar::is_subset
 439     my( $set1, $set2 ) = @_;
 440     my %all;
 441     map { $all{$_} = 1 } $set2->members;
 442     foreach my $m ( $set1->members ) {
 443         return 0 unless $all{$m};
 444     }
 445     return 1;
 446 }
 447
 448 sub TO_JSON {
 449         my $self = shift;
 450         # Required values: graph and setlist
 451         my $data = {
 452                 graph => $self->graph,
 453                 setlist => [],
 454         };
 455         foreach my $set ( $self->sets ) {
 456                 push( @{$data->{setlist}}, [ $set->members ] );
 457         }
 458         # Scalar values, if they are set
 459         $data->{is_genealogical} = 1 if $self->is_genealogical;
 460         $data->{status} = $self->status if $self->status;
 461
 462         # Set values, if they exist
 463         $data->{groupinglist} = [] if $self->groupings;
 464         foreach my $group ( $self->groupings ) {
 465                 push( @{$data->{groupinglist}}, [ $group->members ] );
 466         }
 467         $data->{classlist} = {} if $self->assigned_wits;
 468         foreach my $wit ( $self->assigned_wits ) {
 469                 $data->{classlist}->{$wit} = $self->class( $wit );
 470         }
 471         return $data;
 472 }
 473
 474 sub throw {
 475         Text::Tradition::Error->throw(
 476                 'ident' => 'Analysis::Result error',
 477                 'message' => $_[0],
 478         );
 479 }
 480
 481 no Moose;
 482 __PACKAGE__->meta->make_immutable;
 483
 484 1;