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 'status' => (
  72         is => 'rw',
  73         isa => 'Str'
  74 );
  75
  76 has 'is_genealogical' => (
  77         is => 'rw',
  78         isa => 'Bool',
  79         predicate => 'has_genealogical_result'
  80 );
  81
  82 has 'groupinglist' => (
  83         traits => ['Array'],
  84         isa => 'ArrayRef[Set::Scalar]',
  85         handles => {
  86                 groupings => 'elements',
  87                 _add_grouping => 'push',
  88                 _set_grouping => 'set',
  89                 grouping => 'get',
  90         },
  91         default => sub { [] }
  92 );
  93
  94 has 'classlist' => (
  95         traits => ['Hash'],
  96         isa => 'HashRef[Str]',
  97         handles => {
  98                 class => 'get',
  99                 has_class => 'exists',
 100                 set_class => 'set',
 101                 classes => 'elements',
 102                 assigned_wits => 'keys',
 103         },
 104 );
 105
 106 around BUILDARGS => sub {
 107         my $orig = shift;
 108         my $class = shift;
 109         my $args = @_ == 1 ? $_[0] : { @_ };
 110
 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'} ) ];
 119
 120         # If we have been passed a Text::Tradition::Stemma or a Graph, save only
 121         # its string.
 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 );
 130                 } else {
 131                         die "Passed argument to graph that is neither Stemma nor Graph";
 132                 }
 133         }
 134
 135         # If our only args are graph and setlist, then status should be 'new'
 136         if( scalar keys %$args == 2 ) {
 137                 $args->{'status'} = 'new';
 138         }
 139
 140         return $class->$orig( $args );
 141 };
 142
 143 sub _check_set_args {
 144         my $setlist = shift;
 145         my @sets;
 146         foreach my $set ( @{$setlist} ) {
 147                 my $s = $set;
 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;
 153                 }
 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 );
 158                 }
 159                 # Save the set.
 160                 push( @sets, $s );
 161         }
 162         return @sets;
 163 }
 164
 165 sub BUILD {
 166         my $self = shift;
 167
 168         # Initialize the groupings array
 169         map { $self->_add_grouping( $_ ) } $self->sets;
 170 }
 171
 172 sub record_grouping {
 173         my( $self, $group ) = @_;
 174         unless( ref( $group ) eq 'Set::Scalar' ) {
 175                 my $s = Set::Scalar->new( @$group );
 176                 $group = $s;
 177         }
 178         # Find the set that is a subset of this group, and record it in the
 179         # correct spot in our groupinglist.
 180         my $idx = 0;
 181         foreach my $set ( $self->sets ) {
 182                 if( _is_subset( $set, $group ) ) {
 183                         $self->_set_grouping( $idx, $group );
 184                         last;
 185                 }
 186                 $idx++;
 187         }
 188         if( $idx == scalar( $self->sets ) ) {
 189                 throw( "Failed to find witness set that is a subset of $group" );
 190         }
 191 }
 192
 193 sub _is_subset {
 194     # A replacement for the stupid Set::Scalar::is_subset
 195     my( $set1, $set2 ) = @_;
 196     my %all;
 197     map { $all{$_} = 1 } $set2->members;
 198     foreach my $m ( $set1->members ) {
 199         return 0 unless $all{$m};
 200     }
 201     return 1;
 202 }
 203
 204 # A request string is the graph followed by the groups, which should form a unique
 205 # key for the result.
 206 sub object_key {
 207         my $self = shift;
 208         return md5_hex( encode_utf8( $self->request_string ) );
 209 }
 210
 211 sub request_string {
 212         my $self = shift;
 213         return string_from_graph_problem( $self->graph, [ $self->sets ] );
 214 }
 215
 216 sub string_from_graph_problem {
 217         my( $graph, $grouping ) = @_;
 218         my( $graphstr, @groupsets );
 219         # Get the graph string
 220         if( ref( $graph ) && ref( $graph ) eq 'Graph' ) {
 221                 $graphstr = Text::Tradition::Stemma::editable_graph( $graph, { 'linesep' => ' ' } );
 222         } else {
 223                 throw( "Passed non-graph object $graph to stringification" )
 224                         if ref( $graph );
 225                 $graphstr = $graph;
 226         }
 227         # Make sure all groupings are sets
 228         foreach my $g ( @$grouping ) {
 229                 if( ref( $g ) eq 'ARRAY' ) {
 230                         push( @groupsets, Set::Scalar->new( @$g ) );
 231                 } elsif( ref( $g ) eq 'Set::Scalar' ) {
 232                         push( @groupsets, $g );
 233                 } else {
 234                         throw( "Tried to stringify grouping $g that is neither set nor array" );
 235                 }
 236         }
 237         return $graphstr . '//' .
 238                 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
 239 }
 240
 241 # This should work as $self->problem_json or as problem_json( @objects )
 242 sub problem_json {
 243         my( @objects ) = @_;
 244         # There should be a distinct problem for each unique graph.
 245         my %distinct_problems;
 246         foreach my $o ( @objects ) {
 247                 unless( exists $distinct_problems{$o->graph} ) {
 248                         $distinct_problems{$o->graph} = [];
 249                 }
 250                 my @groupings;
 251                 map { push( @groupings, [ $_->members ] ) } $o->sets;
 252                 push( @{$distinct_problems{$o->graph}}, \@groupings );
 253         }
 254         my @pstrs = map { to_json(
 255                 { graph => $_, groupings => $distinct_problems{$_} } ) }
 256                 keys %distinct_problems;
 257         return @pstrs;
 258 }
 259
 260 sub by_size_and_alpha {
 261         my( $a, $b ) = @_;
 262         my $size = $b->members <=> $a->members;
 263         return $size if $size;
 264         # Then sort by alphabetical order of set elements.
 265         return "$a" cmp "$b";
 266 }
 267
 268 sub sources {
 269         my $self = shift;
 270         my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
 271         return @sources;
 272 }
 273
 274 # Look for a matching set in our setlist, and return its corresponding group
 275 sub minimum_grouping_for {
 276         my( $self, $set ) = @_;
 277         my $midx = $self->set_index( sub { "$set" eq "$_" } );
 278         return undef unless defined $midx;
 279         return $self->grouping( $midx );
 280 }
 281
 282 sub TO_JSON {
 283         my $self = shift;
 284         # Graph and setlist
 285         my $data = {
 286                 graph => $self->graph,
 287                 setlist => [],
 288                 groupinglist => [],
 289                 classlist => {}
 290         };
 291         $data->{is_genealogical} = 1 if $self->is_genealogical;
 292         foreach my $set ( $self->sets ) {
 293                 push( @{$data->{setlist}}, [ $set->members ] );
 294         }
 295         # groupinglist
 296         foreach my $group ( $self->groupings ) {
 297                 push( @{$data->{groupinglist}}, [ $group->members ] );
 298         }
 299         # classlist
 300         foreach my $wit ( $self->assigned_wits ) {
 301                 $data->{classlist}->{$wit} = $self->class( $wit );
 302         }
 303         return $data;
 304 }
 305
 306 sub throw {
 307         Text::Tradition::Error->throw(
 308                 'ident' => 'Analysis::Result error',
 309                 'message' => $_[0],
 310         );
 311 }
 312
 313 no Moose;
 314 __PACKAGE__->meta->make_immutable;
 315
 316 1;