lib/Text/Tradition/Analysis/Result.pm

   1 package Text::Tradition::Analysis::Result;
   2
   3 use Moose;
   4 use Digest::MD5 qw/ md5_hex /;
   5 use Encode qw/ encode_utf8 /;
   6 use JSON qw/ to_json /;
   7 use Set::Scalar;
   8 use Text::Tradition::Error;
   9
  10 =head1 NAME
  11
  12 Text::Tradition::Analysis::Result - object to express an IDP calculation result
  13 for a particular graph problem.
  14
  15 =head1 DESCRIPTION
  16
  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.
  24
  25 For each graph problem, the following features can be calculated:
  26
  27 =over 4
  28
  29 =item * Whether the reading groups form a genealogical pattern on the stemma.
  30
  31 =item * The groupings, including lost/hypothetical witnesses if necessary, that minimize the amount of non-genealogical variation on the stemma.
  32
  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.
  34
  35 =back
  36
  37 =head1 CONSTRUCTOR
  38
  39 =head2 new
  40
  41 Creates a new graph problem. Requires two properties:
  42
  43 =over 4
  44
  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.
  47
  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.
  50
  51 =back
  52
  53 =cut
  54
  55 has 'setlist' => (
  56         traits => ['Array'],
  57         isa => 'ArrayRef[Set::Scalar]',
  58         handles => {
  59                 sets => 'elements',
  60                 set_index => 'first_index',
  61         },
  62         required => 1
  63 );
  64
  65 has 'graph' => (
  66         is => 'ro',
  67         isa => 'Str',
  68         required => 1
  69 );
  70
  71 has 'is_genealogical' => (
  72         is => 'rw',
  73         isa => 'Bool',
  74         predicate => 'has_genealogical_result'
  75 );
  76
  77 has 'groupinglist' => (
  78         traits => ['Array'],
  79         isa => 'ArrayRef[Set::Scalar]',
  80         handles => {
  81                 groupings => 'elements',
  82                 _add_grouping => 'push',
  83                 _set_grouping => 'set',
  84                 grouping => 'get',
  85         },
  86         default => sub { [] }
  87 );
  88
  89 has 'classlist' => (
  90         traits => ['Hash'],
  91         isa => 'HashRef[Str]',
  92         handles => {
  93                 class => 'get',
  94                 has_class => 'exists',
  95                 set_class => 'set',
  96                 classes => 'elements',
  97                 assigned_wits => 'keys',
  98         },
  99 );
 100
 101 around BUILDARGS => sub {
 102         my $orig = shift;
 103         my $class = shift;
 104         my $args = @_ == 1 ? $_[0] : { @_ };
 105
 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'} ) ];
 114
 115         # If we have been passed a Text::Tradition::Stemma or a Graph, save only
 116         # its string.
 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 );
 125                 } else {
 126                         die "Passed argument to graph that is neither Stemma nor Graph";
 127                 }
 128         }
 129
 130         return $class->$orig( $args );
 131 };
 132
 133 sub _check_set_args {
 134         my $setlist = shift;
 135         my @sets;
 136         foreach my $set ( @{$setlist} ) {
 137                 my $s = $set;
 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;
 143                 }
 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 );
 148                 }
 149                 # Save the set.
 150                 push( @sets, $s );
 151         }
 152         return @sets;
 153 }
 154
 155 sub BUILD {
 156         my $self = shift;
 157
 158         # Initialize the groupings array
 159         map { $self->_add_grouping( $_ ) } $self->sets;
 160 }
 161
 162 sub record_grouping {
 163         my( $self, $group ) = @_;
 164         unless( ref( $group ) eq 'Set::Scalar' ) {
 165                 my $s = Set::Scalar->new( @$group );
 166                 $group = $s;
 167         }
 168         # Find the set that is a subset of this group, and record it in the
 169         # correct spot in our groupinglist.
 170         my $idx = 0;
 171         foreach my $set ( $self->sets ) {
 172                 if( $set->is_subset( $group ) ) {
 173                         $self->_set_grouping( $idx, $group );
 174                         last;
 175                 }
 176                 $idx++;
 177         }
 178         if( $idx == scalar( $self->sets ) ) {
 179                 throw( "Failed to find witness set that is a subset of $group" );
 180         }
 181 }
 182
 183 # A request string is the graph followed by the groups, which should form a unique
 184 # key for the result.
 185 sub object_key {
 186         my $self = shift;
 187         return md5_hex( encode_utf8( $self->request_string ) );
 188 }
 189
 190 sub request_string {
 191         my $self = shift;
 192         return string_from_graph_problem( $self->graph, [ $self->sets ] );
 193 }
 194
 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' => ' ' } );
 201         } else {
 202                 throw( "Passed non-graph object $graph to stringification" )
 203                         if ref( $graph );
 204                 $graphstr = $graph;
 205         }
 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 );
 212                 } else {
 213                         throw( "Tried to stringify grouping $g that is neither set nor array" );
 214                 }
 215         }
 216         return $graphstr . '//' .
 217                 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
 218 }
 219
 220 # This should work as $self->problem_json or as problem_json( @objects )
 221 sub problem_json {
 222         my( @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} = [];
 228                 }
 229                 my @groupings;
 230                 map { push( @groupings, [ $_->members ] ) } $o->sets;
 231                 push( @{$distinct_problems{$o->graph}}, \@groupings );
 232         }
 233         my @pstrs = map { to_json(
 234                 { graph => $_, groupings => $distinct_problems{$_} } ) }
 235                 keys %distinct_problems;
 236         return @pstrs;
 237 }
 238
 239 sub by_size_and_alpha {
 240         my( $a, $b ) = @_;
 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";
 245 }
 246
 247 sub sources {
 248         my $self = shift;
 249         my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
 250         return @sources;
 251 }
 252
 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 );
 259 }
 260
 261 sub TO_JSON {
 262         my $self = shift;
 263         # Graph and setlist
 264         my $data = {
 265                 graph => $self->graph,
 266                 setlist => [],
 267                 groupinglist => [],
 268                 classlist => {}
 269         };
 270         $data->{is_genealogical} = 1 if $self->is_genealogical;
 271         foreach my $set ( $self->sets ) {
 272                 push( @{$data->{setlist}}, [ $set->members ] );
 273         }
 274         # groupinglist
 275         foreach my $group ( $self->groupings ) {
 276                 push( @{$data->{groupinglist}}, [ $group->members ] );
 277         }
 278         # classlist
 279         foreach my $wit ( $self->assigned_wits ) {
 280                 $data->{classlist}->{$wit} = $self->class( $wit );
 281         }
 282         return $data;
 283 }
 284
 285 sub throw {
 286         Text::Tradition::Error->throw(
 287                 'ident' => 'Analysis::Result error',
 288                 'message' => $_[0],
 289         );
 290 }
 291
 292 no Moose;
 293 __PACKAGE__->meta->make_immutable;
 294
 295 1;