1 package Text::Tradition::Analysis::Result;
4 use Digest::MD5 qw/ md5_hex /;
5 use Encode qw/ encode_utf8 /;
6 use JSON qw/ to_json /;
8 use Text::Tradition::Error;
12 Text::Tradition::Analysis::Result - object to express an IDP calculation result
13 for a particular graph problem.
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.
25 For each graph problem, the following features can be calculated:
29 =item * Whether the reading groups form a genealogical pattern on the stemma.
31 =item * The groupings, including lost/hypothetical witnesses if necessary, that minimize the amount of non-genealogical variation on the stemma.
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.
41 Creates a new graph problem. Requires two properties:
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.
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.
53 All other properties should be calculated by IDP rather than set manually.
58 =item * is_genealogical - Boolean, indicating whether the witness sets form
59 genealogical groupings on the graph.
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.
66 =item * groupings - These are extended (if necessary) versions of the witness
67 sets, which include the hypothetical witnesses necessary to minimize coincidence
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.
82 use_ok( 'Text::Tradition::Analysis::Result' );
84 # Make a problem with a graph and a set of groupings
86 my $datafile = 't/data/florilegium_tei_ps.xml';
87 my $tradition = Text::Tradition->new( 'input' => 'TEI',
89 'file' => $datafile );
90 my $s = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
92 my $sets = [ [ qw/ D Q / ], [ qw/ F H / ], [ qw/ A B C P S T / ] ];
94 foreach my $set ( @$sets ) {
95 map { $extant->{$_} = 1 } @$set;
97 my $sitgraph = $s->editable( { extant => $extant } );
98 my $result = Text::Tradition::Analysis::Result->new(
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" );
109 # Add some calculation values
110 $result->is_genealogical( 1 );
111 $result->record_grouping( [ qw/ 4 5 D Q / ] );
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" );
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 / ] );
131 foreach my $gp ( $result->groupings ) {
132 map { my $c = $classes{$_} || 'copy'; $result->set_class( $_, $c ) } @$gp;
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" );
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" );
155 =head2 $self->has_class( $witness )
156 =head2 $self->class( $witness )
158 If a class has been calculated for the given witness, has_class returns true
159 and class returns the calculated answer.
165 isa => 'ArrayRef[Set::Scalar]',
168 set_index => 'first_index',
184 has 'is_genealogical' => (
187 predicate => 'has_genealogical_result'
190 has 'groupinglist' => (
192 isa => 'ArrayRef[Set::Scalar]',
194 groupings => 'elements',
195 _add_grouping => 'push',
196 _set_grouping => 'set',
199 default => sub { [] }
204 isa => 'HashRef[Str]',
207 has_class => 'exists',
209 classes => 'elements',
210 assigned_wits => 'keys',
214 around BUILDARGS => sub {
217 my $args = @_ == 1 ? $_[0] : { @_ };
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'} ) ];
232 # If we have been passed a Text::Tradition::Stemma or a Graph, save only
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 );
243 die "Passed argument to graph that is neither Stemma nor Graph";
247 # If our only args are graph and setlist, then status should be 'new'
248 if( scalar keys %$args == 2 ) {
249 $args->{'status'} = 'new';
252 return $class->$orig( $args );
255 sub _check_set_args {
258 foreach my $set ( @{$setlist} ) {
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;
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 );
280 # Initialize the groupings array
281 map { $self->_add_grouping( $_ ) } $self->sets;
284 =head2 $self->object_key
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.
293 return md5_hex( encode_utf8( $self->request_string ) );
296 =head2 $self->request_string
298 A request string is the graph followed by the groups, which should form a unique
305 return $self->graph . '//' . join( ',', $self->sets );
308 =head2 by_size_and_alpha
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.
316 sub by_size_and_alpha {
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";
324 =head2 $self->sources
326 Return all 'source' class witnesses in these sets for this graph.
332 my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
336 =head2 $self->minimum_grouping_for( $set )
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.
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 );
352 =head1 CALCULATION STORAGE METHODS
354 =head2 $self->is_genealogical( $bool )
356 Record that the sets are genealogical for this graph.
358 =head2 $self->set_class( $witness, $class )
360 Record that the witness in question is of the given class.
362 =head2 $self->record_grouping( $group )
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.
370 sub record_grouping {
371 my( $self, $group ) = @_;
372 unless( ref( $group ) eq 'Set::Scalar' ) {
373 my $s = Set::Scalar->new( @$group );
376 # Find the set that is a subset of this group, and record it in the
377 # correct spot in our groupinglist.
379 foreach my $set ( $self->sets ) {
380 if( _is_subset( $set, $group ) ) {
381 $self->_set_grouping( $idx, $group );
386 if( $idx == scalar( $self->sets ) ) {
387 throw( "Failed to find witness set that is a subset of $group" );
392 # A replacement for the stupid Set::Scalar::is_subset
393 my( $set1, $set2 ) = @_;
395 map { $all{$_} = 1 } $set2->members;
396 foreach my $m ( $set1->members ) {
397 return 0 unless $all{$m};
404 # Required values: graph and setlist
406 graph => $self->graph,
409 foreach my $set ( $self->sets ) {
410 push( @{$data->{setlist}}, [ $set->members ] );
412 # Scalar values, if they are set
413 $data->{is_genealogical} = 1 if $self->is_genealogical;
414 $data->{status} = $self->status if $self->status;
416 # Set values, if they exist
417 $data->{groupinglist} = [] if $self->groupings;
418 foreach my $group ( $self->groupings ) {
419 push( @{$data->{groupinglist}}, [ $group->members ] );
421 $data->{classlist} = {} if $self->assigned_wits;
422 foreach my $wit ( $self->assigned_wits ) {
423 $data->{classlist}->{$wit} = $self->class( $wit );
429 Text::Tradition::Error->throw(
430 'ident' => 'Analysis::Result error',
436 __PACKAGE__->meta->make_immutable;