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 or a Graph, save only
 129         # its string.
 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 );
 138                 } else {
 139                         die "Passed argument to graph that is neither Stemma nor Graph";
 140                 }
 141         }
 142
 143         return $class->$orig( $args );
 144 };
 145
 146 sub BUILD {
 147         my $self = shift;
 148
 149         # Initialize the groupings array
 150         map { $self->_add_grouping( $_ ) } $self->sets;
 151 }
 152
 153 sub record_grouping {
 154         my( $self, $group ) = @_;
 155         unless( ref( $group ) eq 'Set::Scalar' ) {
 156                 my $s = Set::Scalar->new( @$group );
 157                 $group = $s;
 158         }
 159         # Find the set that is a subset of this group, and record it in the
 160         # correct spot in our groupinglist.
 161         my $idx = 0;
 162         foreach my $set ( $self->sets ) {
 163                 if( $set->is_subset( $group ) ) {
 164                         $self->_set_grouping( $idx, $group );
 165                         last;
 166                 }
 167                 $idx++;
 168         }
 169         if( $idx == scalar( $self->sets ) ) {
 170                 throw( "Failed to find witness set that is a subset of $group" );
 171         }
 172 }
 173
 174 # A request string is the graph followed by the groups, which should form a unique
 175 # key for the result.
 176 sub request_string {
 177         my $self = shift;
 178         return string_from_graph_problem( $self->graph, [ $self->sets ] );
 179 }
 180
 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' => ' ' } );
 187         } else {
 188                 throw( "Passed non-graph object $graph to stringification" )
 189                         if ref( $graph );
 190                 $graphstr = $graph;
 191         }
 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 );
 198                 } else {
 199                         throw( "Tried to stringify grouping $g that is neither set nor array" );
 200                 }
 201         }
 202         return $graphstr . '//' .
 203                 join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
 204 }
 205
 206 # This should work as $self->problem_json or as problem_json( @objects )
 207 sub problem_json {
 208         my( @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} = [];
 214                 }
 215                 my @groupings;
 216                 map { push( @groupings, [ $_->members ] ) } $o->sets;
 217                 push( @{$distinct_problems{$o->graph}}, \@groupings );
 218         }
 219         my @pstrs = map { to_json(
 220                 { graph => $_, groupings => $distinct_problems{$_} } ) }
 221                 keys %distinct_problems;
 222         return @pstrs;
 223 }
 224
 225 sub by_size_and_alpha {
 226         my( $a, $b ) = @_;
 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";
 231 }
 232
 233 sub sources {
 234         my $self = shift;
 235         my @sources = grep { $self->class( $_ ) eq 'source' } $self->assigned_wits;
 236         return @sources;
 237 }
 238
 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 );
 245 }
 246
 247 sub throw {
 248         Text::Tradition::Error->throw(
 249                 'ident' => 'Analysis::Result error',
 250                 'message' => $_[0],
 251         );
 252 }
 253
 254 no Moose;
 255 __PACKAGE__->meta->make_immutable;
 256
 257 1;