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.
57 isa => 'ArrayRef[Set::Scalar]',
60 set_index => 'first_index',
71 has 'is_genealogical' => (
74 predicate => 'has_genealogical_result'
77 has 'groupinglist' => (
79 isa => 'ArrayRef[Set::Scalar]',
81 groupings => 'elements',
82 _add_grouping => 'push',
83 _set_grouping => 'set',
91 isa => 'HashRef[Str]',
94 has_class => 'exists',
96 classes => 'elements',
97 assigned_wits => 'keys',
101 around BUILDARGS => sub {
104 my $args = @_ == 1 ? $_[0] : { @_ };
106 # Convert the set list into a list of Set::Scalars, ordered first by size and
107 # then alphabetically by first-sorted.
108 die "Must specify a set list to Analysis::Result->new()"
109 unless ref( $args->{'setlist'} ) eq 'ARRAY';
110 # Order the sets and make sure they are all distinct Set::Scalars.
111 $args->{'setlist'} = _check_set_args( $args->{'setlist'} );
112 $args->{'groupinglist'} = _check_set_args( $args->{'groupinglist'} );
114 # If we have been passed a Text::Tradition::Stemma or a Graph, save only
116 if( ref( $args->{'graph'} ) ) {
117 my $st = delete $args->{'graph'};
118 my $type = ref( $st );
119 my $gopt = { linesep => ' ' };
120 if( $type eq 'Text::Tradition::Stemma' ) {
121 $args->{'graph'} = $st->editable( $gopt );
122 } elsif( $type eq 'Graph' ) {
123 $args->{'graph'} = Text::Tradition::Stemma::editable_graph( $st, $gopt );
125 die "Passed argument to graph that is neither Stemma nor Graph";
129 return $class->$orig( $args );
132 sub _check_set_args {
135 foreach my $set ( @{$setlist} ) {
137 # Check uniqueness of the current set
138 if( ref( $set ) ne 'Set::Scalar' ) {
139 $s = Set::Scalar->new( @$set );
140 die "Duplicate element(s) in set or group passed to Analysis::Result->new()"
141 unless @$set == $s->elements;
143 # Check distinctness of the set from all other sets given so far
144 foreach my $ps ( @sets ) {
145 die "Two sets are not disjoint"
146 unless $s->is_disjoint( $ps );
151 return [ sort { by_size_and_alpha( $a, $b ) } @sets ];
157 # Initialize the groupings array
158 map { $self->_add_grouping( $_ ) } $self->sets;
161 sub record_grouping {
162 my( $self, $group ) = @_;
163 unless( ref( $group ) eq 'Set::Scalar' ) {
164 my $s = Set::Scalar->new( @$group );
167 # Find the set that is a subset of this group, and record it in the
168 # correct spot in our groupinglist.
170 foreach my $set ( $self->sets ) {
171 if( $set->is_subset( $group ) ) {
172 $self->_set_grouping( $idx, $group );
177 if( $idx == scalar( $self->sets ) ) {
178 throw( "Failed to find witness set that is a subset of $group" );
182 # A request string is the graph followed by the groups, which should form a unique
183 # key for the result.
186 return md5_hex( encode_utf8( $self->request_string ) );
191 return string_from_graph_problem( $self->graph, [ $self->sets ] );
194 sub string_from_graph_problem {
195 my( $graph, $grouping ) = @_;
196 my( $graphstr, @groupsets );
197 # Get the graph string
198 if( ref( $graph ) && ref( $graph ) eq 'Graph' ) {
199 $graphstr = Text::Tradition::Stemma::editable_graph( $graph, { 'linesep' => ' ' } );
201 throw( "Passed non-graph object $graph to stringification" )
205 # Make sure all groupings are sets
206 foreach my $g ( @$grouping ) {
207 if( ref( $g ) eq 'ARRAY' ) {
208 push( @groupsets, Set::Scalar->new( @$g ) );
209 } elsif( ref( $g ) eq 'Set::Scalar' ) {
210 push( @groupsets, $g );
212 throw( "Tried to stringify grouping $g that is neither set nor array" );
215 return $graphstr . '//' .
216 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
219 # This should work as $self->problem_json or as problem_json( @objects )
222 # There should be a distinct problem for each unique graph.
223 my %distinct_problems;
224 foreach my $o ( @objects ) {
225 unless( exists $distinct_problems{$o->graph} ) {
226 $distinct_problems{$o->graph} = [];
229 map { push( @groupings, [ $_->members ] ) } $o->sets;
230 push( @{$distinct_problems{$o->graph}}, \@groupings );
232 my @pstrs = map { to_json(
233 { graph => $_, groupings => $distinct_problems{$_} } ) }
234 keys %distinct_problems;
238 sub by_size_and_alpha {
240 my $size = $b->members <=> $a->members;
241 return $size if $size;
242 # Then sort by alphabetical order of set elements.
243 return "$a" cmp "$b";
248 my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
252 # Look for a matching set in our setlist, and return its corresponding group
253 sub minimum_grouping_for {
254 my( $self, $set ) = @_;
255 my $midx = $self->set_index( sub { "$set" eq "$_" } );
256 return undef unless defined $midx;
257 return $self->grouping( $midx );
264 graph => $self->graph,
269 $data->{is_genealogical} = 1 if $self->is_genealogical;
270 foreach my $set ( $self->sets ) {
271 push( @{$data->{setlist}}, [ $set->members ] );
274 foreach my $group ( $self->groupings ) {
275 push( @{$data->{groupinglist}}, [ $group->members ] );
278 foreach my $wit ( $self->assigned_wits ) {
279 $data->{classlist}->{$wit} = $self->class( $wit );
285 Text::Tradition::Error->throw(
286 'ident' => 'Analysis::Result error',
292 __PACKAGE__->meta->make_immutable;