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'} = _check_set_args( $args->{'setlist'} );
 112         $args->{'groupinglist'} = _check_set_args( $args->{'groupinglist'} );
 113
 114         # If we have been passed a Text::Tradition::Stemma or a Graph, save only
 115         # its string.
 116         if( ref( $args->{'graph'} ) ) {
 117                 my $st = delete $args->{'graph'};
 118                 my $type = ref( $st );
 119                 my $gopt = { linesep => ' ' };
 120                 if( $type eq 'Text::Tradition::Stemma' ) {
 121                         $args->{'graph'} = $st->editable( $gopt );
 122                 } elsif( $type eq 'Graph' ) {
 123                         $args->{'graph'} = Text::Tradition::Stemma::editable_graph( $st, $gopt );
 124                 } else {
 125                         die "Passed argument to graph that is neither Stemma nor Graph";
 126                 }
 127         }
 128
 129         return $class->$orig( $args );
 130 };
 131
 132 sub _check_set_args {
 133         my $setlist = shift;
 134         my @sets;
 135         foreach my $set ( @{$setlist} ) {
 136                 my $s = $set;
 137                 # Check uniqueness of the current set
 138                 if( ref( $set ) ne 'Set::Scalar' ) {
 139                         $s = Set::Scalar->new( @$set );
 140                         die "Duplicate element(s) in set or group passed to Analysis::Result->new()"
 141                                 unless @$set == $s->elements;
 142                 }
 143                 # Check distinctness of the set from all other sets given so far
 144                 foreach my $ps ( @sets ) {
 145                         die "Two sets are not disjoint"
 146                                 unless $s->is_disjoint( $ps );
 147                 }
 148                 # Save the set.
 149                 push( @sets, $s );
 150         }
 151         return [ sort { by_size_and_alpha( $a, $b ) } @sets ];
 152 }
 153
 154 sub BUILD {
 155         my $self = shift;
 156
 157         # Initialize the groupings array
 158         map { $self->_add_grouping( $_ ) } $self->sets;
 159 }
 160
 161 sub record_grouping {
 162         my( $self, $group ) = @_;
 163         unless( ref( $group ) eq 'Set::Scalar' ) {
 164                 my $s = Set::Scalar->new( @$group );
 165                 $group = $s;
 166         }
 167         # Find the set that is a subset of this group, and record it in the
 168         # correct spot in our groupinglist.
 169         my $idx = 0;
 170         foreach my $set ( $self->sets ) {
 171                 if( $set->is_subset( $group ) ) {
 172                         $self->_set_grouping( $idx, $group );
 173                         last;
 174                 }
 175                 $idx++;
 176         }
 177         if( $idx == scalar( $self->sets ) ) {
 178                 throw( "Failed to find witness set that is a subset of $group" );
 179         }
 180 }
 181
 182 # A request string is the graph followed by the groups, which should form a unique
 183 # key for the result.
 184 sub object_key {
 185         my $self = shift;
 186         return md5_hex( encode_utf8( $self->request_string ) );
 187 }
 188
 189 sub request_string {
 190         my $self = shift;
 191         return string_from_graph_problem( $self->graph, [ $self->sets ] );
 192 }
 193
 194 sub string_from_graph_problem {
 195         my( $graph, $grouping ) = @_;
 196         my( $graphstr, @groupsets );
 197         # Get the graph string
 198         if( ref( $graph ) && ref( $graph ) eq 'Graph' ) {
 199                 $graphstr = Text::Tradition::Stemma::editable_graph( $graph, { 'linesep' => ' ' } );
 200         } else {
 201                 throw( "Passed non-graph object $graph to stringification" )
 202                         if ref( $graph );
 203                 $graphstr = $graph;
 204         }
 205         # Make sure all groupings are sets
 206         foreach my $g ( @$grouping ) {
 207                 if( ref( $g ) eq 'ARRAY' ) {
 208                         push( @groupsets, Set::Scalar->new( @$g ) );
 209                 } elsif( ref( $g ) eq 'Set::Scalar' ) {
 210                         push( @groupsets, $g );
 211                 } else {
 212                         throw( "Tried to stringify grouping $g that is neither set nor array" );
 213                 }
 214         }
 215         return $graphstr . '//' .
 216                 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
 217 }
 218
 219 # This should work as $self->problem_json or as problem_json( @objects )
 220 sub problem_json {
 221         my( @objects ) = @_;
 222         # There should be a distinct problem for each unique graph.
 223         my %distinct_problems;
 224         foreach my $o ( @objects ) {
 225                 unless( exists $distinct_problems{$o->graph} ) {
 226                         $distinct_problems{$o->graph} = [];
 227                 }
 228                 my @groupings;
 229                 map { push( @groupings, [ $_->members ] ) } $o->sets;
 230                 push( @{$distinct_problems{$o->graph}}, \@groupings );
 231         }
 232         my @pstrs = map { to_json(
 233                 { graph => $_, groupings => $distinct_problems{$_} } ) }
 234                 keys %distinct_problems;
 235         return @pstrs;
 236 }
 237
 238 sub by_size_and_alpha {
 239         my( $a, $b ) = @_;
 240         my $size = $b->members <=> $a->members;
 241         return $size if $size;
 242         # Then sort by alphabetical order of set elements.
 243         return "$a" cmp "$b";
 244 }
 245
 246 sub sources {
 247         my $self = shift;
 248         my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
 249         return @sources;
 250 }
 251
 252 # Look for a matching set in our setlist, and return its corresponding group
 253 sub minimum_grouping_for {
 254         my( $self, $set ) = @_;
 255         my $midx = $self->set_index( sub { "$set" eq "$_" } );
 256         return undef unless defined $midx;
 257         return $self->grouping( $midx );
 258 }
 259
 260 sub TO_JSON {
 261         my $self = shift;
 262         # Graph and setlist
 263         my $data = {
 264                 graph => $self->graph,
 265                 setlist => [],
 266                 groupinglist => [],
 267                 classlist => {}
 268         };
 269         $data->{is_genealogical} = 1 if $self->is_genealogical;
 270         foreach my $set ( $self->sets ) {
 271                 push( @{$data->{setlist}}, [ $set->members ] );
 272         }
 273         # groupinglist
 274         foreach my $group ( $self->groupings ) {
 275                 push( @{$data->{groupinglist}}, [ $group->members ] );
 276         }
 277         # classlist
 278         foreach my $wit ( $self->assigned_wits ) {
 279                 $data->{classlist}->{$wit} = $self->class( $wit );
 280         }
 281         return $data;
 282 }
 283
 284 sub throw {
 285         Text::Tradition::Error->throw(
 286                 'ident' => 'Analysis::Result error',
 287                 'message' => $_[0],
 288         );
 289 }
 290
 291 no Moose;
 292 __PACKAGE__->meta->make_immutable;
 293
 294 1;