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         die "Empty set list specified to Analysis::Result->new()"
 224                 unless @{$args->{'setlist'}};
 225         # Order the sets and make sure they are all distinct Set::Scalars.
 226         $args->{'setlist'} = [ sort { by_size_and_alpha( $a, $b ) }
 227                                                         _check_set_args( $args->{'setlist'} ) ];
 228         if( exists $args->{'groupinglist'} ) {
 229                 $args->{'groupinglist'} = [ _check_set_args( $args->{'groupinglist'} ) ];
 230         }
 231
 232         # If we have been passed a Text::Tradition::Stemma or a Graph, save only
 233         # its string.
 234         if( ref( $args->{'graph'} ) ) {
 235                 my $st = delete $args->{'graph'};
 236                 my $type = ref( $st );
 237                 my $gopt = { linesep => ' ' };
 238                 if( $type eq 'Text::Tradition::Stemma' ) {
 239                         $args->{'graph'} = $st->editable( $gopt );
 240                 } elsif( $type eq 'Graph' ) {
 241                         $args->{'graph'} = Text::Tradition::Stemma::editable_graph( $st, $gopt );
 242                 } else {
 243                         die "Passed argument to graph that is neither Stemma nor Graph";
 244                 }
 245         }
 246
 247         # If our only args are graph and setlist, then status should be 'new'
 248         if( scalar keys %$args == 2 ) {
 249                 $args->{'status'} = 'new';
 250         }
 251
 252         return $class->$orig( $args );
 253 };
 254
 255 sub _check_set_args {
 256         my $setlist = shift;
 257         my @sets;
 258         foreach my $set ( @{$setlist} ) {
 259                 my $s = $set;
 260                 # Check uniqueness of the current set
 261                 if( ref( $set ) ne 'Set::Scalar' ) {
 262                         $s = Set::Scalar->new( @$set );
 263                         die "Duplicate element(s) in set or group passed to Analysis::Result->new()"
 264                                 unless @$set == $s->elements;
 265                 }
 266                 # Check distinctness of the set from all other sets given so far
 267                 foreach my $ps ( @sets ) {
 268                         die "Two sets are not disjoint"
 269                                 unless $s->is_disjoint( $ps );
 270                 }
 271                 # Save the set.
 272                 push( @sets, $s );
 273         }
 274         return @sets;
 275 }
 276
 277 sub BUILD {
 278         my $self = shift;
 279
 280         # Initialize the groupings array
 281         map { $self->_add_grouping( $_ ) } $self->sets;
 282 }
 283
 284 =head2 $self->object_key
 285
 286 Returns a unique key that can be used to look up this graph/set combination in
 287 a database. Currently an MD5 hash of the request_string.
 288
 289 =cut
 290
 291 sub object_key {
 292         my $self = shift;
 293         return md5_hex( encode_utf8( $self->request_string ) );
 294 }
 295
 296 =head2 $self->request_string
 297
 298 A request string is the graph followed by the groups, which should form a unique
 299 key for the result.
 300
 301 =cut
 302
 303 sub request_string {
 304         my $self = shift;
 305         return $self->graph . '//' . join( ',', $self->sets );
 306 }
 307
 308 =head2 by_size_and_alpha
 309
 310 A useful utility function to sort Set::Scalar objects first in descending
 311 order by size, then in ascending alphabetical order by first element (i.e.
 312 by stringification.)
 313
 314 =cut
 315
 316 sub by_size_and_alpha {
 317         my( $a, $b ) = @_;
 318         my $size = $b->members <=> $a->members;
 319         return $size if $size;
 320         # Then sort by alphabetical order of set elements.
 321         return "$a" cmp "$b";
 322 }
 323
 324 =head2 $self->sources
 325
 326 Return all 'source' class witnesses in these sets for this graph.
 327
 328 =cut
 329
 330 sub sources {
 331         my $self = shift;
 332         my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
 333         return @sources;
 334 }
 335
 336 =head2 $self->minimum_grouping_for( $set )
 337
 338 Return the minimum grouping (including necessary hypothetical witnesses) for
 339 the witness set specified. Will return undef if $set does not match one of
 340 the defined witness sets in $self->sets.
 341
 342 =cut
 343
 344 # Look for a matching set in our setlist, and return its corresponding group
 345 sub minimum_grouping_for {
 346         my( $self, $set ) = @_;
 347         my $midx = $self->set_index( sub { "$set" eq "$_" } );
 348         return undef unless defined $midx;
 349         return $self->grouping( $midx );
 350 }
 351
 352 =head1 CALCULATION STORAGE METHODS
 353
 354 =head2 $self->is_genealogical( $bool )
 355
 356 Record that the sets are genealogical for this graph.
 357
 358 =head2 $self->set_class( $witness, $class )
 359
 360 Record that the witness in question is of the given class.
 361
 362 =head2 $self->record_grouping( $group )
 363
 364 Record that the group in question (either an arrayref or a Set::Scalar) forms
 365 a minimum grouping on the graph. Will throw an error unless the group is a
 366 (non-proper) superset of an existing witness set.
 367
 368 =cut
 369
 370 sub record_grouping {
 371         my( $self, $group ) = @_;
 372         unless( ref( $group ) eq 'Set::Scalar' ) {
 373                 my $s = Set::Scalar->new( @$group );
 374                 $group = $s;
 375         }
 376         # Find the set that is a subset of this group, and record it in the
 377         # correct spot in our groupinglist.
 378         my $idx = 0;
 379         foreach my $set ( $self->sets ) {
 380                 if( _is_subset( $set, $group ) ) {
 381                         $self->_set_grouping( $idx, $group );
 382                         last;
 383                 }
 384                 $idx++;
 385         }
 386         if( $idx == scalar( $self->sets ) ) {
 387                 throw( "Failed to find witness set that is a subset of $group" );
 388         }
 389 }
 390
 391 sub _is_subset {
 392     # A replacement for the stupid Set::Scalar::is_subset
 393     my( $set1, $set2 ) = @_;
 394     my %all;
 395     map { $all{$_} = 1 } $set2->members;
 396     foreach my $m ( $set1->members ) {
 397         return 0 unless $all{$m};
 398     }
 399     return 1;
 400 }
 401
 402 sub TO_JSON {
 403         my $self = shift;
 404         # Required values: graph and setlist
 405         my $data = {
 406                 graph => $self->graph,
 407                 setlist => [],
 408         };
 409         foreach my $set ( $self->sets ) {
 410                 push( @{$data->{setlist}}, [ $set->members ] );
 411         }
 412         # Scalar values, if they are set
 413         $data->{is_genealogical} = 1 if $self->is_genealogical;
 414         $data->{status} = $self->status if $self->status;
 415
 416         # Set values, if they exist
 417         $data->{groupinglist} = [] if $self->groupings;
 418         foreach my $group ( $self->groupings ) {
 419                 push( @{$data->{groupinglist}}, [ $group->members ] );
 420         }
 421         $data->{classlist} = {} if $self->assigned_wits;
 422         foreach my $wit ( $self->assigned_wits ) {
 423                 $data->{classlist}->{$wit} = $self->class( $wit );
 424         }
 425         return $data;
 426 }
 427
 428 sub throw {
 429         Text::Tradition::Error->throw(
 430                 'ident' => 'Analysis::Result error',
 431                 'message' => $_[0],
 432         );
 433 }
 434
 435 no Moose;
 436 __PACKAGE__->meta->make_immutable;
 437
 438 1;