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( $set->is_subset( $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" );
193 # A request string is the graph followed by the groups, which should form a unique
194 # key for the result.
197 return md5_hex( encode_utf8( $self->request_string ) );
202 return string_from_graph_problem( $self->graph, [ $self->sets ] );
205 sub string_from_graph_problem {
206 my( $graph, $grouping ) = @_;
207 my( $graphstr, @groupsets );
208 # Get the graph string
209 if( ref( $graph ) && ref( $graph ) eq 'Graph' ) {
210 $graphstr = Text::Tradition::Stemma::editable_graph( $graph, { 'linesep' => ' ' } );
212 throw( "Passed non-graph object $graph to stringification" )
216 # Make sure all groupings are sets
217 foreach my $g ( @$grouping ) {
218 if( ref( $g ) eq 'ARRAY' ) {
219 push( @groupsets, Set::Scalar->new( @$g ) );
220 } elsif( ref( $g ) eq 'Set::Scalar' ) {
221 push( @groupsets, $g );
223 throw( "Tried to stringify grouping $g that is neither set nor array" );
226 return $graphstr . '//' .
227 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
230 # This should work as $self->problem_json or as problem_json( @objects )
233 # There should be a distinct problem for each unique graph.
234 my %distinct_problems;
235 foreach my $o ( @objects ) {
236 unless( exists $distinct_problems{$o->graph} ) {
237 $distinct_problems{$o->graph} = [];
240 map { push( @groupings, [ $_->members ] ) } $o->sets;
241 push( @{$distinct_problems{$o->graph}}, \@groupings );
243 my @pstrs = map { to_json(
244 { graph => $_, groupings => $distinct_problems{$_} } ) }
245 keys %distinct_problems;
249 sub by_size_and_alpha {
251 my $size = $b->members <=> $a->members;
252 return $size if $size;
253 # Then sort by alphabetical order of set elements.
254 return "$a" cmp "$b";
259 my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
263 # Look for a matching set in our setlist, and return its corresponding group
264 sub minimum_grouping_for {
265 my( $self, $set ) = @_;
266 my $midx = $self->set_index( sub { "$set" eq "$_" } );
267 return undef unless defined $midx;
268 return $self->grouping( $midx );
275 graph => $self->graph,
280 $data->{is_genealogical} = 1 if $self->is_genealogical;
281 foreach my $set ( $self->sets ) {
282 push( @{$data->{setlist}}, [ $set->members ] );
285 foreach my $group ( $self->groupings ) {
286 push( @{$data->{groupinglist}}, [ $group->members ] );
289 foreach my $wit ( $self->assigned_wits ) {
290 $data->{classlist}->{$wit} = $self->class( $wit );
296 Text::Tradition::Error->throw(
297 'ident' => 'Analysis::Result error',
303 __PACKAGE__->meta->make_immutable;