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 # 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'} ) ];
230 # If we have been passed a Text::Tradition::Stemma or a Graph, save only
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 );
241 die "Passed argument to graph that is neither Stemma nor Graph";
245 # If our only args are graph and setlist, then status should be 'new'
247 if( scalar keys %$args == 2 ) {
248 $args->{'status'} = 'new';
251 return $class->$orig( $args );
254 sub _check_set_args {
257 foreach my $set ( @{$setlist} ) {
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;
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 );
279 # Initialize the groupings array
280 map { $self->_add_grouping( $_ ) } $self->sets;
283 =head2 $self->object_key
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.
292 return md5_hex( encode_utf8( $self->request_string ) );
295 =head2 $self->request_string
297 A request string is the graph followed by the groups, which should form a unique
304 return string_from_graph_problem( $self->graph, [ $self->sets ] );
307 # TODO do we need this now?
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' => ' ' } );
316 throw( "Passed non-graph object $graph to stringification" )
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 );
327 throw( "Tried to stringify grouping $g that is neither set nor array" );
330 return $graphstr . '//' .
331 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
334 # TODO do we need this?
335 # This should work as $self->problem_json or as problem_json( @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} = [];
345 map { push( @groupings, [ $_->members ] ) } $o->sets;
346 push( @{$distinct_problems{$o->graph}}, \@groupings );
348 my @pstrs = map { to_json(
349 { graph => $_, groupings => $distinct_problems{$_} } ) }
350 keys %distinct_problems;
354 =head2 by_size_and_alpha
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.
362 sub by_size_and_alpha {
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";
370 =head2 $self->sources
372 Return all 'source' class witnesses in these sets for this graph.
378 my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
382 =head2 $self->minimum_grouping_for( $set )
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.
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 );
398 =head1 CALCULATION STORAGE METHODS
400 =head2 $self->is_genealogical( $bool )
402 Record that the sets are genealogical for this graph.
404 =head2 $self->set_class( $witness, $class )
406 Record that the witness in question is of the given class.
408 =head2 $self->record_grouping( $group )
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.
416 sub record_grouping {
417 my( $self, $group ) = @_;
418 unless( ref( $group ) eq 'Set::Scalar' ) {
419 my $s = Set::Scalar->new( @$group );
422 # Find the set that is a subset of this group, and record it in the
423 # correct spot in our groupinglist.
425 foreach my $set ( $self->sets ) {
426 if( _is_subset( $set, $group ) ) {
427 $self->_set_grouping( $idx, $group );
432 if( $idx == scalar( $self->sets ) ) {
433 throw( "Failed to find witness set that is a subset of $group" );
438 # A replacement for the stupid Set::Scalar::is_subset
439 my( $set1, $set2 ) = @_;
441 map { $all{$_} = 1 } $set2->members;
442 foreach my $m ( $set1->members ) {
443 return 0 unless $all{$m};
450 # Required values: graph and setlist
452 graph => $self->graph,
455 foreach my $set ( $self->sets ) {
456 push( @{$data->{setlist}}, [ $set->members ] );
458 # Scalar values, if they are set
459 $data->{is_genealogical} = 1 if $self->is_genealogical;
460 $data->{status} = $self->status if $self->status;
462 # Set values, if they exist
463 $data->{groupinglist} = [] if $self->groupings;
464 foreach my $group ( $self->groupings ) {
465 push( @{$data->{groupinglist}}, [ $group->members ] );
467 $data->{classlist} = {} if $self->assigned_wits;
468 foreach my $wit ( $self->assigned_wits ) {
469 $data->{classlist}->{$wit} = $self->class( $wit );
475 Text::Tradition::Error->throw(
476 'ident' => 'Analysis::Result error',
482 __PACKAGE__->meta->make_immutable;