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',
76 has 'is_genealogical' => (
79 predicate => 'has_genealogical_result'
82 has 'groupinglist' => (
84 isa => 'ArrayRef[Set::Scalar]',
86 groupings => 'elements',
87 _add_grouping => 'push',
88 _set_grouping => 'set',
96 isa => 'HashRef[Str]',
99 has_class => 'exists',
101 classes => 'elements',
102 assigned_wits => 'keys',
106 around BUILDARGS => sub {
109 my $args = @_ == 1 ? $_[0] : { @_ };
111 # Convert the set list into a list of Set::Scalars, ordered first by size and
112 # then alphabetically by first-sorted.
113 die "Must specify a set list to Analysis::Result->new()"
114 unless ref( $args->{'setlist'} ) eq 'ARRAY';
115 # Order the sets and make sure they are all distinct Set::Scalars.
116 $args->{'setlist'} = [ sort { by_size_and_alpha( $a, $b ) }
117 _check_set_args( $args->{'setlist'} ) ];
118 $args->{'groupinglist'} = [ _check_set_args( $args->{'groupinglist'} ) ];
120 # If we have been passed a Text::Tradition::Stemma or a Graph, save only
122 if( ref( $args->{'graph'} ) ) {
123 my $st = delete $args->{'graph'};
124 my $type = ref( $st );
125 my $gopt = { linesep => ' ' };
126 if( $type eq 'Text::Tradition::Stemma' ) {
127 $args->{'graph'} = $st->editable( $gopt );
128 } elsif( $type eq 'Graph' ) {
129 $args->{'graph'} = Text::Tradition::Stemma::editable_graph( $st, $gopt );
131 die "Passed argument to graph that is neither Stemma nor Graph";
135 # If our only args are graph and setlist, then status should be 'new'
136 if( scalar keys %$args == 2 ) {
137 $args->{'status'} = 'new';
140 return $class->$orig( $args );
143 sub _check_set_args {
146 foreach my $set ( @{$setlist} ) {
148 # Check uniqueness of the current set
149 if( ref( $set ) ne 'Set::Scalar' ) {
150 $s = Set::Scalar->new( @$set );
151 die "Duplicate element(s) in set or group passed to Analysis::Result->new()"
152 unless @$set == $s->elements;
154 # Check distinctness of the set from all other sets given so far
155 foreach my $ps ( @sets ) {
156 die "Two sets are not disjoint"
157 unless $s->is_disjoint( $ps );
168 # Initialize the groupings array
169 map { $self->_add_grouping( $_ ) } $self->sets;
172 sub record_grouping {
173 my( $self, $group ) = @_;
174 unless( ref( $group ) eq 'Set::Scalar' ) {
175 my $s = Set::Scalar->new( @$group );
178 # Find the set that is a subset of this group, and record it in the
179 # correct spot in our groupinglist.
181 foreach my $set ( $self->sets ) {
182 if( _is_subset( $set, $group ) ) {
183 $self->_set_grouping( $idx, $group );
188 if( $idx == scalar( $self->sets ) ) {
189 throw( "Failed to find witness set that is a subset of $group" );
194 # A replacement for the stupid Set::Scalar::is_subset
195 my( $set1, $set2 ) = @_;
197 map { $all{$_} = 1 } $set2->members;
198 foreach my $m ( $set1->members ) {
199 return 0 unless $all{$m};
204 # A request string is the graph followed by the groups, which should form a unique
205 # key for the result.
208 return md5_hex( encode_utf8( $self->request_string ) );
213 return string_from_graph_problem( $self->graph, [ $self->sets ] );
216 sub string_from_graph_problem {
217 my( $graph, $grouping ) = @_;
218 my( $graphstr, @groupsets );
219 # Get the graph string
220 if( ref( $graph ) && ref( $graph ) eq 'Graph' ) {
221 $graphstr = Text::Tradition::Stemma::editable_graph( $graph, { 'linesep' => ' ' } );
223 throw( "Passed non-graph object $graph to stringification" )
227 # Make sure all groupings are sets
228 foreach my $g ( @$grouping ) {
229 if( ref( $g ) eq 'ARRAY' ) {
230 push( @groupsets, Set::Scalar->new( @$g ) );
231 } elsif( ref( $g ) eq 'Set::Scalar' ) {
232 push( @groupsets, $g );
234 throw( "Tried to stringify grouping $g that is neither set nor array" );
237 return $graphstr . '//' .
238 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
241 # This should work as $self->problem_json or as problem_json( @objects )
244 # There should be a distinct problem for each unique graph.
245 my %distinct_problems;
246 foreach my $o ( @objects ) {
247 unless( exists $distinct_problems{$o->graph} ) {
248 $distinct_problems{$o->graph} = [];
251 map { push( @groupings, [ $_->members ] ) } $o->sets;
252 push( @{$distinct_problems{$o->graph}}, \@groupings );
254 my @pstrs = map { to_json(
255 { graph => $_, groupings => $distinct_problems{$_} } ) }
256 keys %distinct_problems;
260 sub by_size_and_alpha {
262 my $size = $b->members <=> $a->members;
263 return $size if $size;
264 # Then sort by alphabetical order of set elements.
265 return "$a" cmp "$b";
270 my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
274 # Look for a matching set in our setlist, and return its corresponding group
275 sub minimum_grouping_for {
276 my( $self, $set ) = @_;
277 my $midx = $self->set_index( sub { "$set" eq "$_" } );
278 return undef unless defined $midx;
279 return $self->grouping( $midx );
286 graph => $self->graph,
291 $data->{is_genealogical} = 1 if $self->is_genealogical;
292 foreach my $set ( $self->sets ) {
293 push( @{$data->{setlist}}, [ $set->members ] );
296 foreach my $group ( $self->groupings ) {
297 push( @{$data->{groupinglist}}, [ $group->members ] );
300 foreach my $wit ( $self->assigned_wits ) {
301 $data->{classlist}->{$wit} = $self->class( $wit );
307 Text::Tradition::Error->throw(
308 'ident' => 'Analysis::Result error',
314 __PACKAGE__->meta->make_immutable;