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'} = [ sort { by_size_and_alpha( $a, $b ) }
112 _check_set_args( $args->{'setlist'} ) ];
113 $args->{'groupinglist'} = [ _check_set_args( $args->{'groupinglist'} ) ];
115 # If we have been passed a Text::Tradition::Stemma or a Graph, save only
117 if( ref( $args->{'graph'} ) ) {
118 my $st = delete $args->{'graph'};
119 my $type = ref( $st );
120 my $gopt = { linesep => ' ' };
121 if( $type eq 'Text::Tradition::Stemma' ) {
122 $args->{'graph'} = $st->editable( $gopt );
123 } elsif( $type eq 'Graph' ) {
124 $args->{'graph'} = Text::Tradition::Stemma::editable_graph( $st, $gopt );
126 die "Passed argument to graph that is neither Stemma nor Graph";
130 return $class->$orig( $args );
133 sub _check_set_args {
136 foreach my $set ( @{$setlist} ) {
138 # Check uniqueness of the current set
139 if( ref( $set ) ne 'Set::Scalar' ) {
140 $s = Set::Scalar->new( @$set );
141 die "Duplicate element(s) in set or group passed to Analysis::Result->new()"
142 unless @$set == $s->elements;
144 # Check distinctness of the set from all other sets given so far
145 foreach my $ps ( @sets ) {
146 die "Two sets are not disjoint"
147 unless $s->is_disjoint( $ps );
158 # Initialize the groupings array
159 map { $self->_add_grouping( $_ ) } $self->sets;
162 sub record_grouping {
163 my( $self, $group ) = @_;
164 unless( ref( $group ) eq 'Set::Scalar' ) {
165 my $s = Set::Scalar->new( @$group );
168 # Find the set that is a subset of this group, and record it in the
169 # correct spot in our groupinglist.
171 foreach my $set ( $self->sets ) {
172 if( $set->is_subset( $group ) ) {
173 $self->_set_grouping( $idx, $group );
178 if( $idx == scalar( $self->sets ) ) {
179 throw( "Failed to find witness set that is a subset of $group" );
183 # A request string is the graph followed by the groups, which should form a unique
184 # key for the result.
187 return md5_hex( encode_utf8( $self->request_string ) );
192 return string_from_graph_problem( $self->graph, [ $self->sets ] );
195 sub string_from_graph_problem {
196 my( $graph, $grouping ) = @_;
197 my( $graphstr, @groupsets );
198 # Get the graph string
199 if( ref( $graph ) && ref( $graph ) eq 'Graph' ) {
200 $graphstr = Text::Tradition::Stemma::editable_graph( $graph, { 'linesep' => ' ' } );
202 throw( "Passed non-graph object $graph to stringification" )
206 # Make sure all groupings are sets
207 foreach my $g ( @$grouping ) {
208 if( ref( $g ) eq 'ARRAY' ) {
209 push( @groupsets, Set::Scalar->new( @$g ) );
210 } elsif( ref( $g ) eq 'Set::Scalar' ) {
211 push( @groupsets, $g );
213 throw( "Tried to stringify grouping $g that is neither set nor array" );
216 return $graphstr . '//' .
217 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
220 # This should work as $self->problem_json or as problem_json( @objects )
223 # There should be a distinct problem for each unique graph.
224 my %distinct_problems;
225 foreach my $o ( @objects ) {
226 unless( exists $distinct_problems{$o->graph} ) {
227 $distinct_problems{$o->graph} = [];
230 map { push( @groupings, [ $_->members ] ) } $o->sets;
231 push( @{$distinct_problems{$o->graph}}, \@groupings );
233 my @pstrs = map { to_json(
234 { graph => $_, groupings => $distinct_problems{$_} } ) }
235 keys %distinct_problems;
239 sub by_size_and_alpha {
241 my $size = $b->members <=> $a->members;
242 return $size if $size;
243 # Then sort by alphabetical order of set elements.
244 return "$a" cmp "$b";
249 my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
253 # Look for a matching set in our setlist, and return its corresponding group
254 sub minimum_grouping_for {
255 my( $self, $set ) = @_;
256 my $midx = $self->set_index( sub { "$set" eq "$_" } );
257 return undef unless defined $midx;
258 return $self->grouping( $midx );
265 graph => $self->graph,
270 $data->{is_genealogical} = 1 if $self->is_genealogical;
271 foreach my $set ( $self->sets ) {
272 push( @{$data->{setlist}}, [ $set->members ] );
275 foreach my $group ( $self->groupings ) {
276 push( @{$data->{groupinglist}}, [ $group->members ] );
279 foreach my $wit ( $self->assigned_wits ) {
280 $data->{classlist}->{$wit} = $self->class( $wit );
286 Text::Tradition::Error->throw(
287 'ident' => 'Analysis::Result error',
293 __PACKAGE__->meta->make_immutable;