1 package Text::Tradition::Analysis::Result;
4 use JSON qw/ to_json /;
6 use Text::Tradition::Error;
10 Text::Tradition::Analysis::Result - object to express an IDP calculation result
11 for a particular graph problem.
15 Given a graph (expressing a stemma hypothesis) and a set of witness groupings
16 (expressing variation in reading between witnesses related according to the
17 stemma hypothesis), it is possible to calculate certain properties of how the
18 readings might be related to each other. This calculation depends on a custom
19 program run under the IDP system [TODO URL]. As the problem is NP-hard, the
20 calculation can take a long time. The purpose of this object is to allow storage
21 of calculated results in a database.
23 For each graph problem, the following features can be calculated:
27 =item * Whether the reading groups form a genealogical pattern on the stemma.
29 =item * The groupings, including lost/hypothetical witnesses if necessary, that minimize the amount of non-genealogical variation on the stemma.
31 =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.
39 Creates a new graph problem. Requires two properties:
43 =item * setlist - An array of arrays expressing the witness sets. The inner
44 arrays will be converted to Set::Scalar objects, and must have distinct members.
46 =item * graph - A dot description of a graph (e.g. the output of a call to
47 Text::Tradition::Stemma::editable) against which the sets will be analyzed.
55 isa => 'ArrayRef[Set::Scalar]',
58 set_index => 'first_index',
69 has 'is_genealogical' => (
72 predicate => 'has_genealogical_result'
75 has 'groupinglist' => (
77 isa => 'ArrayRef[Set::Scalar]',
79 groupings => 'elements',
80 _add_grouping => 'push',
81 _set_grouping => 'set',
89 isa => 'HashRef[Str]',
92 has_class => 'exists',
94 classes => 'elements',
95 assigned_wits => 'keys',
99 around BUILDARGS => sub {
102 my $args = @_ == 1 ? $_[0] : { @_ };
104 # Convert the set list into a list of Set::Scalars, ordered first by size and
105 # then alphabetically by first-sorted.
106 die "Must specify a set list to Analysis::Result->new()"
107 unless ref( $args->{'setlist'} ) eq 'ARRAY';
109 foreach my $set ( @{$args->{'setlist'}} ) {
111 # Check uniqueness of the current set
112 if( ref( $set ) ne 'Set::Scalar' ) {
113 $s = Set::Scalar->new( @$set );
114 die "Duplicate element(s) in set passed to Analysis::Result->new()"
115 unless @$set == $s->elements;
117 # Check distinctness of the set from all other sets given so far
118 foreach my $ps ( @sets ) {
119 die "Two sets are not disjoint"
120 unless $s->is_disjoint( $ps );
126 $args->{'setlist'} = [ sort { by_size_and_alpha( $a, $b ) } @sets ];
128 # If we have been passed a Text::Tradition::Stemma or a Graph, save only
130 if( ref( $args->{'graph'} ) ) {
131 my $st = delete $args->{'graph'};
132 my $type = ref( $st );
133 my $gopt = { linesep => ' ' };
134 if( $type eq 'Text::Tradition::Stemma' ) {
135 $args->{'graph'} = $st->editable( $gopt );
136 } elsif( $type eq 'Graph' ) {
137 $args->{'graph'} = Text::Tradition::Stemma::editable_graph( $st, $gopt );
139 die "Passed argument to graph that is neither Stemma nor Graph";
143 return $class->$orig( $args );
149 # Initialize the groupings array
150 map { $self->_add_grouping( $_ ) } $self->sets;
153 sub record_grouping {
154 my( $self, $group ) = @_;
155 unless( ref( $group ) eq 'Set::Scalar' ) {
156 my $s = Set::Scalar->new( @$group );
159 # Find the set that is a subset of this group, and record it in the
160 # correct spot in our groupinglist.
162 foreach my $set ( $self->sets ) {
163 if( $set->is_subset( $group ) ) {
164 $self->_set_grouping( $idx, $group );
169 if( $idx == scalar( $self->sets ) ) {
170 throw( "Failed to find witness set that is a subset of $group" );
174 # A request string is the graph followed by the groups, which should form a unique
175 # key for the result.
178 return string_from_graph_problem( $self->graph, [ $self->sets ] );
181 sub string_from_graph_problem {
182 my( $graph, $grouping ) = @_;
183 my( $graphstr, @groupsets );
184 # Get the graph string
185 if( ref( $graph ) && ref( $graph ) eq 'Graph' ) {
186 $graphstr = Text::Tradition::Stemma::editable_graph( $graph, { 'linesep' => ' ' } );
188 throw( "Passed non-graph object $graph to stringification" )
192 # Make sure all groupings are sets
193 foreach my $g ( @$grouping ) {
194 if( ref( $g ) eq 'ARRAY' ) {
195 push( @groupsets, Set::Scalar->new( @$g ) );
196 } elsif( ref( $g ) eq 'Set::Scalar' ) {
197 push( @groupsets, $g );
199 throw( "Tried to stringify grouping $g that is neither set nor array" );
202 return $graphstr . '//' .
203 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
206 # This should work as $self->problem_json or as problem_json( @objects )
209 # There should be a distinct problem for each unique graph.
210 my %distinct_problems;
211 foreach my $o ( @objects ) {
212 unless( exists $distinct_problems{$o->graph} ) {
213 $distinct_problems{$o->graph} = [];
216 map { push( @groupings, [ $_->members ] ) } $o->sets;
217 push( @{$distinct_problems{$o->graph}}, \@groupings );
219 my @pstrs = map { to_json(
220 { graph => $_, groupings => $distinct_problems{$_} } ) }
221 keys %distinct_problems;
225 sub by_size_and_alpha {
227 my $size = $b->members <=> $a->members;
228 return $size if $size;
229 # Then sort by alphabetical order of set elements.
230 return "$a" cmp "$b";
235 my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
239 # Look for a matching set in our setlist, and return its corresponding group
240 sub minimum_grouping_for {
241 my( $self, $set ) = @_;
242 my $midx = $self->set_index( sub { "$set" eq "$_" } );
243 return undef unless defined $midx;
244 return $self->grouping( $midx );
248 Text::Tradition::Error->throw(
249 'ident' => 'Analysis::Result error',
255 __PACKAGE__->meta->make_immutable;