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 Set::Scalar;
  80 use Test::More::UTF8;
  81 use Text::Tradition;
  82 use TryCatch;
  83 use_ok( 'Text::Tradition::Analysis::Result' );
  84
  85 # Make a problem with a graph and a set of groupings
  86
  87 my $datafile = 't/data/florilegium_tei_ps.xml';
  88 my $tradition = Text::Tradition->new( 'input' => 'TEI',
  89                                       'name' => 'flortest',
  90                                       'file' => $datafile );
  91 my $s = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
  92
  93 my $sets = [ [ qw/ D Q / ], [ qw/ F H / ], [ qw/ A B C P S T / ] ];
  94 my $extant = {};
  95 foreach my $set ( @$sets ) {
  96         map { $extant->{$_} = 1 } @$set;
  97 }
  98 my $sitgraph = $s->editable( { extant => $extant } );
  99 my $result = Text::Tradition::Analysis::Result->new(
 100         graph => $sitgraph,
 101         setlist => $sets );
 102 is( ref( $result ), 'Text::Tradition::Analysis::Result', "Got a Result object" );
 103 is( $result->graph, $sitgraph, "Got identical graph string back" );
 104 is( $result->status, "new", "Calculation status of result set correctly" );
 105 my @rsets = $result->sets;
 106 is( $rsets[0], '(A B C P S T)', "First set is biggest set" );
 107 is( $rsets[1], '(D Q)', "Second set is by alphabetical order" );
 108 is( $rsets[2], '(F H)', "Second set is by alphabetical order" );
 109
 110 # Add some calculation values
 111 $result->is_genealogical( 1 );
 112 $result->record_grouping( [ qw/ 4 5 D Q / ] );
 113 try {
 114         $result->record_grouping( [ qw/ 3 4 D H / ] );
 115         ok( 0, "Recorded a grouping that does not match the input sets" );
 116 } catch ( Text::Tradition::Error $e ) {
 117         like( $e->message, qr/Failed to find witness set that is a subset of/,
 118                 "Correct error thrown on bad record_grouping attempt" );
 119 }
 120 # Test manually setting an out-of-range group
 121 try {
 122         $result->_set_grouping( 3, Set::Scalar->new( qw/ X Y / ) );
 123         ok( 0, "Set a grouping at an invalid index" );
 124 } catch ( Text::Tradition::Error $e ) {
 125         is( $e->message, 'Set / group index 3 out of range for set_grouping',
 126                 "Caught attempt to set grouping at invalid index" );
 127 }
 128 $result->record_grouping( [ qw/ 3 F H / ] );
 129 my $gp1 = $result->grouping(1);
 130 is( $result->minimum_grouping_for( $rsets[1] ), $gp1,
 131         "Found a minimum grouping for D Q" );
 132 is( "$gp1", "(4 5 D Q)", "Retrieved minimum grouping is correct" );
 133 is( $result->minimum_grouping_for( $rsets[0] ), $rsets[0],
 134         "Default minimum grouping found for biggest group" );
 135 $result->record_grouping( [ qw/ 1 α δ A B C P S T / ] );
 136 my %classes = (
 137         α => 'source',
 138         3 => 'source',
 139         4 => 'source' );
 140 foreach my $gp ( $result->groupings ) {
 141         map { my $c = $classes{$_} || 'copy'; $result->set_class( $_, $c ) } @$gp;
 142 }
 143 foreach my $gp ( $result->groupings ) {
 144         foreach my $wit ( @$gp ) {
 145                 my $expected = $classes{$wit} || 'copy';
 146                 is( $result->class( $wit ), $expected, "Got expected witness class for $wit" );
 147         }
 148 }
 149
 150 # Now write it out to JSON
 151 my $struct = $result->TO_JSON;
 152 my $newresult = Text::Tradition::Analysis::Result->new( $struct );
 153 is( $result->object_key, $newresult->object_key,
 154         "Object key stayed constant on export/import" );
 155 my $problem = Text::Tradition::Analysis::Result->new( graph => $sitgraph, setlist => $sets );
 156 is( $problem->object_key, $result->object_key,
 157         "Object key stayed constant for newly created problem" );
 158
 159
 160 =end testing
 161
 162 =head1 METHODS
 163
 164 =head2 $self->has_class( $witness )
 165 =head2 $self->class( $witness )
 166
 167 If a class has been calculated for the given witness, has_class returns true
 168 and class returns the calculated answer.
 169
 170 =cut
 171
 172 has 'setlist' => (
 173         traits => ['Array'],
 174         isa => 'ArrayRef[Set::Scalar]',
 175         handles => {
 176                 sets => 'elements',
 177                 set_index => 'first_index',
 178         },
 179         required => 1
 180 );
 181
 182 has 'graph' => (
 183         is => 'ro',
 184         isa => 'Str',
 185         required => 1
 186 );
 187
 188 has 'status' => (
 189         is => 'rw',
 190         isa => 'Str'
 191 );
 192
 193 has 'is_genealogical' => (
 194         is => 'rw',
 195         isa => 'Bool',
 196         predicate => 'has_genealogical_result'
 197 );
 198
 199 has 'groupinglist' => (
 200         traits => ['Array'],
 201         isa => 'ArrayRef[Set::Scalar]',
 202         handles => {
 203                 groupings => 'elements',
 204                 _set_grouping => 'set',
 205                 grouping => 'get',
 206         },
 207         default => sub { [] }
 208 );
 209
 210 has 'classlist' => (
 211         traits => ['Hash'],
 212         isa => 'HashRef[Str]',
 213         handles => {
 214                 class => 'get',
 215                 has_class => 'exists',
 216                 set_class => 'set',
 217                 classes => 'elements',
 218                 assigned_wits => 'keys',
 219         },
 220 );
 221
 222 around BUILDARGS => sub {
 223         my $orig = shift;
 224         my $class = shift;
 225         my $args = @_ == 1 ? $_[0] : { @_ };
 226
 227         # Convert the set list into a list of Set::Scalars, ordered first by size and
 228         # then alphabetically by first-sorted.
 229         throw( "Must specify a set list to Analysis::Result->new()" )
 230                 unless ref( $args->{'setlist'} ) eq 'ARRAY';
 231         throw( "Empty set list specified to Analysis::Result->new()" )
 232                 unless @{$args->{'setlist'}};
 233         # Order the sets and make sure they are all distinct Set::Scalars.
 234         $args->{'setlist'} = [ sort { by_size_and_alpha( $a, $b ) }
 235                                                         _check_set_args( $args->{'setlist'} ) ];
 236         if( exists $args->{'groupinglist'} ) {
 237                 $args->{'groupinglist'} = [ _check_set_args( $args->{'groupinglist'} ) ];
 238         }
 239
 240         # If we have been passed a Text::Tradition::Stemma or a Graph, save only
 241         # its string.
 242         if( ref( $args->{'graph'} ) ) {
 243                 my $st = delete $args->{'graph'};
 244                 my $type = ref( $st );
 245                 my $gopt = { linesep => ' ' };
 246                 if( $type eq 'Text::Tradition::Stemma' ) {
 247                         $args->{'graph'} = $st->editable( $gopt );
 248                 } elsif( $type eq 'Graph' ) {
 249                         $args->{'graph'} = Text::Tradition::Stemma::editable_graph( $st, $gopt );
 250                 } else {
 251                         throw( "Passed argument to graph that is neither Stemma nor Graph" );
 252                 }
 253         }
 254
 255         # If our only args are graph and setlist, then status should be 'new'
 256         if( scalar keys %$args == 2 ) {
 257                 $args->{'status'} = 'new';
 258         }
 259
 260         return $class->$orig( $args );
 261 };
 262
 263 sub _check_set_args {
 264         my $setlist = shift;
 265         my @sets;
 266         foreach my $set ( @{$setlist} ) {
 267                 my $s = $set;
 268                 # Check uniqueness of the current set
 269                 if( ref( $set ) ne 'Set::Scalar' ) {
 270                         $s = Set::Scalar->new( @$set );
 271                         throw( "Duplicate element(s) in set or group passed to Analysis::Result->new()" )
 272                                 unless @$set == $s->elements;
 273                 }
 274                 # Check distinctness of the set from all other sets given so far
 275                 foreach my $ps ( @sets ) {
 276                         throw( "Two sets $s / $ps are not disjoint" )
 277                                 unless $s->is_disjoint( $ps );
 278                 }
 279                 # Save the set.
 280                 push( @sets, $s );
 281         }
 282         return @sets;
 283 }
 284
 285 sub BUILD {
 286         my $self = shift;
 287
 288         # Initialize the groupings array
 289         my @sets = $self->sets;
 290         foreach my $idx( 0 .. $#sets ) {
 291                 unless( $self->grouping( $idx ) ) {
 292                         my $g = $sets[$idx]->clone();
 293                         $self->_set_grouping( $idx, $g );
 294                 }
 295         }
 296 }
 297
 298 before '_set_grouping' => sub {
 299         my $self = shift;
 300         my $idx = $_[0];
 301         my $max = scalar $self->sets;
 302         if( $idx >= $max ) {
 303                 throw( "Set / group index $idx out of range for set_grouping" );
 304         }
 305 };
 306
 307 =head2 $self->object_key
 308
 309 Returns a unique key that can be used to look up this graph/set combination in
 310 a database. Currently an MD5 hash of the request_string.
 311
 312 =cut
 313
 314 sub object_key {
 315         my $self = shift;
 316         return md5_hex( encode_utf8( $self->request_string ) );
 317 }
 318
 319 =head2 $self->request_string
 320
 321 A request string is the graph followed by the groups, which should form a unique
 322 key for the result.
 323
 324 =cut
 325
 326 sub request_string {
 327         my $self = shift;
 328         return $self->graph . '//' . join( ',', $self->sets );
 329 }
 330
 331 =head2 by_size_and_alpha
 332
 333 A useful utility function to sort Set::Scalar objects first in descending
 334 order by size, then in ascending alphabetical order by first element (i.e.
 335 by stringification.)
 336
 337 =cut
 338
 339 sub by_size_and_alpha {
 340         my( $a, $b ) = @_;
 341         my $size = $b->members <=> $a->members;
 342         return $size if $size;
 343         # Then sort by alphabetical order of set elements.
 344         return "$a" cmp "$b";
 345 }
 346
 347 =head2 $self->sources
 348
 349 Return all 'source' class witnesses in these sets for this graph.
 350
 351 =cut
 352
 353 sub sources {
 354         my $self = shift;
 355         my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
 356         return @sources;
 357 }
 358
 359 =head2 $self->minimum_grouping_for( $set )
 360
 361 Return the minimum grouping (including necessary hypothetical witnesses) for
 362 the witness set specified. Will return undef if $set does not match one of
 363 the defined witness sets in $self->sets.
 364
 365 =cut
 366
 367 # Look for a matching set in our setlist, and return its corresponding group
 368 sub minimum_grouping_for {
 369         my( $self, $set ) = @_;
 370         my $midx = $self->set_index( sub { "$set" eq "$_" } );
 371         return undef unless defined $midx;
 372         return $self->grouping( $midx );
 373 }
 374
 375 =head1 CALCULATION STORAGE METHODS
 376
 377 =head2 $self->is_genealogical( $bool )
 378
 379 Record that the sets are genealogical for this graph.
 380
 381 =head2 $self->set_class( $witness, $class )
 382
 383 Record that the witness in question is of the given class.
 384
 385 =head2 $self->record_grouping( $group )
 386
 387 Record that the group in question (either an arrayref or a Set::Scalar) forms
 388 a minimum grouping on the graph. Will throw an error unless the group is a
 389 (non-proper) superset of an existing witness set.
 390
 391 =cut
 392
 393 sub record_grouping {
 394         my( $self, $group ) = @_;
 395         unless( ref( $group ) eq 'Set::Scalar' ) {
 396                 my $s = Set::Scalar->new( @$group );
 397                 $group = $s;
 398         }
 399         # Find the set that is a subset of this group, and record it in the
 400         # correct spot in our groupinglist.
 401         my $idx = 0;
 402         foreach my $set ( $self->sets ) {
 403                 if( _is_subset( $set, $group ) ) {
 404                         $self->_set_grouping( $idx, $group );
 405                         last;
 406                 }
 407                 $idx++;
 408         }
 409         if( $idx == scalar( $self->sets ) ) {
 410                 throw( "Failed to find witness set that is a subset of $group" );
 411         }
 412 }
 413
 414 sub _is_subset {
 415     # A replacement for the stupid Set::Scalar::is_subset
 416     my( $set1, $set2 ) = @_;
 417     my %all;
 418     map { $all{$_} = 1 } $set2->members;
 419     foreach my $m ( $set1->members ) {
 420         return 0 unless $all{$m};
 421     }
 422     return 1;
 423 }
 424
 425 sub TO_JSON {
 426         my $self = shift;
 427         # Required values: graph and setlist
 428         my $data = {
 429                 graph => $self->graph,
 430                 setlist => [],
 431         };
 432         foreach my $set ( $self->sets ) {
 433                 push( @{$data->{setlist}}, [ $set->members ] );
 434         }
 435         # Scalar values, if they are set
 436         $data->{is_genealogical} = 1 if $self->is_genealogical;
 437         $data->{status} = $self->status if $self->status;
 438
 439         # Set values, if they exist
 440         $data->{groupinglist} = [] if $self->groupings;
 441         foreach my $group ( $self->groupings ) {
 442                 push( @{$data->{groupinglist}}, [ $group->members ] );
 443         }
 444         $data->{classlist} = {} if $self->assigned_wits;
 445         foreach my $wit ( $self->assigned_wits ) {
 446                 $data->{classlist}->{$wit} = $self->class( $wit );
 447         }
 448         return $data;
 449 }
 450
 451 sub throw {
 452         Text::Tradition::Error->throw(
 453                 'ident' => 'Analysis::Result error',
 454                 'message' => $_[0],
 455         );
 456 }
 457
 458 no Moose;
 459 __PACKAGE__->meta->make_immutable;
 460
 461 1;