lib/Text/Tradition/Analysis/Result.pm

   1 package Text::Tradition::Analysis::Result;
   2
   3 use Moose;
   4 use JSON qw/ to_json /;
   5 use Set::Scalar;
   6 use Text::Tradition::Error;
   7
   8 =head1 NAME
   9
  10 Text::Tradition::Analysis::Result - object to express an IDP calculation result
  11 for a particular graph problem.
  12
  13 =head1 DESCRIPTION
  14
  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.
  22
  23 For each graph problem, the following features can be calculated:
  24
  25 =over 4
  26
  27 =item * Whether the reading groups form a genealogical pattern on the stemma.
  28
  29 =item * The groupings, including lost/hypothetical witnesses if necessary, that minimize the amount of non-genealogical variation on the stemma.
  30
  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.
  32
  33 =back
  34
  35 =head1 CONSTRUCTOR
  36
  37 =head2 new
  38
  39 Creates a new graph problem. Requires two properties:
  40
  41 =over 4
  42
  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.
  45
  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.
  48
  49 =back
  50
  51 =cut
  52
  53 has 'setlist' => (
  54         traits => ['Array'],
  55         isa => 'ArrayRef[Set::Scalar]',
  56         handles => {
  57                 sets => 'elements',
  58                 set_index => 'first_index',
  59         },
  60         required => 1
  61 );
  62
  63 has 'graph' => (
  64         is => 'ro',
  65         isa => 'Str',
  66         required => 1
  67 );
  68
  69 has 'is_genealogical' => (
  70         is => 'rw',
  71         isa => 'Bool',
  72         predicate => 'has_genealogical_result'
  73 );
  74
  75 has 'groupinglist' => (
  76         traits => ['Array'],
  77         isa => 'ArrayRef[Set::Scalar]',
  78         handles => {
  79                 groupings => 'elements',
  80                 _add_grouping => 'push',
  81                 _set_grouping => 'set',
  82                 grouping => 'get',
  83         },
  84         default => sub { [] }
  85 );
  86
  87 has 'classlist' => (
  88         traits => ['Hash'],
  89         isa => 'HashRef[Str]',
  90         handles => {
  91                 class => 'get',
  92                 has_class => 'exists',
  93                 set_class => 'set',
  94                 classes => 'elements',
  95                 assigned_wits => 'keys',
  96         },
  97 );
  98
  99 around BUILDARGS => sub {
 100         my $orig = shift;
 101         my $class = shift;
 102         my $args = @_ == 1 ? $_[0] : { @_ };
 103
 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';
 108         my @sets;
 109         foreach my $set ( @{$args->{'setlist'}} ) {
 110                 my $s = $set;
 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;
 116                 }
 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 );
 121                 }
 122                 # Save the set.
 123                 push( @sets, $s );
 124         }
 125         # Order the sets.
 126         $args->{'setlist'} = [ sort { by_size_and_alpha( $a, $b ) } @sets ];
 127
 128         # If we have been passed a Text::Tradition::Stemma, save only its graph.
 129         if( ref( $args->{'graph'} ) eq 'Text::Tradition::Stemma' ) {
 130                 my $st = delete $args->{'graph'};
 131                 $args->{'graph'} = $st->editable;
 132         }
 133
 134         return $class->$orig( $args );
 135 };
 136
 137 sub BUILD {
 138         my $self = shift;
 139
 140         # Initialize the groupings array
 141         map { $self->_add_grouping( $_ ) } $self->sets;
 142 }
 143
 144 sub record_grouping {
 145         my( $self, $group ) = @_;
 146         unless( ref( $group ) eq 'Set::Scalar' ) {
 147                 my $s = Set::Scalar->new( @$group );
 148                 $group = $s;
 149         }
 150         # Find the set that is a subset of this group, and record it in the
 151         # correct spot in our groupinglist.
 152         my $idx = 0;
 153         foreach my $set ( $self->sets ) {
 154                 if( $set->is_subset( $group ) ) {
 155                         $self->_set_grouping( $idx, $group );
 156                         last;
 157                 }
 158                 $idx++;
 159         }
 160         if( $idx == scalar( $self->sets ) ) {
 161                 throw( "Failed to find witness set that is a subset of $group" );
 162         }
 163 }
 164
 165 # A request string is the graph followed by the groups, which should form a unique
 166 # key for the result.
 167 sub request_string {
 168         my $self = shift;
 169         return string_from_graph_problem( $self->graph, [ $self->sets ] );
 170 }
 171
 172 sub string_from_graph_problem {
 173         my( $graph, $grouping ) = @_;
 174         my( $graphstr, @groupsets );
 175         # Get the graph string
 176         if( ref( $graph ) && ref( $graph ) eq 'Graph' ) {
 177                 $graphstr = Text::Tradition::Stemma::editable_graph( $graph, { 'linesep' => ' ' } );
 178         } else {
 179                 throw( "Passed non-graph object $graph to stringification" )
 180                         if ref( $graph );
 181                 $graphstr = $graph;
 182         }
 183         # Make sure all groupings are sets
 184         foreach my $g ( @$grouping ) {
 185                 if( ref( $g ) eq 'ARRAY' ) {
 186                         push( @groupsets, Set::Scalar->new( @$g ) );
 187                 } elsif( ref( $g ) eq 'Set::Scalar' ) {
 188                         push( @groupsets, $g );
 189                 } else {
 190                         throw( "Tried to stringify grouping $g that is neither set nor array" );
 191                 }
 192         }
 193         return $graphstr . '//' .
 194                 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
 195 }
 196
 197 sub problem_json {
 198         my $self = shift;
 199         my $phash = { graph => $self->graph };
 200         my @groupings;
 201         map { push( @groupings, [ $_->members ] ) } $self->sets;
 202         $phash->{groupings} = \@groupings;
 203         return to_json( $phash );
 204 }
 205
 206 sub by_size_and_alpha {
 207         my( $a, $b ) = @_;
 208         my $size = $b->members <=> $a->members;
 209         return $size if $size;
 210         # Then sort by alphabetical order of set elements.
 211         return "$a" cmp "$b";
 212 }
 213
 214 sub sources {
 215         my $self = shift;
 216         my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
 217         return @sources;
 218 }
 219
 220 # Look for a matching set in our setlist, and return its corresponding group
 221 sub minimum_grouping_for {
 222         my( $self, $set ) = @_;
 223         my $midx = $self->set_index( sub { "$set" eq "$_" } );
 224         return undef unless defined $midx;
 225         return $self->grouping( $midx );
 226 }
 227
 228 sub throw {
 229         Text::Tradition::Error->throw(
 230                 'ident' => 'Analysis::Result error',
 231                 'message' => $_[0],
 232         );
 233 }
 234
 235 no Moose;
 236 __PACKAGE__->meta->make_immutable;
 237
 238 1;