analysis/t/text_tradition_analysis_result.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Test::More 'no_plan';
   5 $| = 1;
   6
   7
   8
   9 # =begin testing
  10 {
  11 use Set::Scalar;
  12 use Test::More::UTF8;
  13 use Text::Tradition;
  14 use TryCatch;
  15 use_ok( 'Text::Tradition::Analysis::Result' );
  16
  17 # Make a problem with a graph and a set of groupings
  18
  19 my $datafile = 't/data/florilegium_tei_ps.xml';
  20 my $tradition = Text::Tradition->new( 'input' => 'TEI',
  21                                       'name' => 'flortest',
  22                                       'file' => $datafile );
  23 my $s = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
  24
  25 my $sets = [ [ qw/ D Q / ], [ qw/ F H / ], [ qw/ A B C P S T / ] ];
  26 my $extant = {};
  27 foreach my $set ( @$sets ) {
  28         map { $extant->{$_} = 1 } @$set;
  29 }
  30 my $sitgraph = $s->editable( { extant => $extant } );
  31 my $result = Text::Tradition::Analysis::Result->new(
  32         graph => $sitgraph,
  33         setlist => $sets );
  34 is( ref( $result ), 'Text::Tradition::Analysis::Result', "Got a Result object" );
  35 is( $result->graph, $sitgraph, "Got identical graph string back" );
  36 is( $result->status, "new", "Calculation status of result set correctly" );
  37 my @rsets = $result->sets;
  38 is( $rsets[0], '(A B C P S T)', "First set is biggest set" );
  39 is( $rsets[1], '(D Q)', "Second set is by alphabetical order" );
  40 is( $rsets[2], '(F H)', "Second set is by alphabetical order" );
  41
  42 # Add some calculation values
  43 $result->is_genealogical( 1 );
  44 $result->record_grouping( [ qw/ 4 5 D Q / ] );
  45 try {
  46         $result->record_grouping( [ qw/ 3 4 D H / ] );
  47         ok( 0, "Recorded a grouping that does not match the input sets" );
  48 } catch ( Text::Tradition::Error $e ) {
  49         like( $e->message, qr/Failed to find witness set that is a subset of/,
  50                 "Correct error thrown on bad record_grouping attempt" );
  51 }
  52 # Test manually setting an out-of-range group
  53 try {
  54         $result->_set_grouping( 3, Set::Scalar->new( qw/ X Y / ) );
  55         ok( 0, "Set a grouping at an invalid index" );
  56 } catch ( Text::Tradition::Error $e ) {
  57         is( $e->message, 'Set / group index 3 out of range for set_grouping',
  58                 "Caught attempt to set grouping at invalid index" );
  59 }
  60 $result->record_grouping( [ qw/ 3 F H / ] );
  61 my $gp1 = $result->grouping(1);
  62 is( $result->minimum_grouping_for( $rsets[1] ), $gp1,
  63         "Found a minimum grouping for D Q" );
  64 is( "$gp1", "(4 5 D Q)", "Retrieved minimum grouping is correct" );
  65 is( $result->minimum_grouping_for( $rsets[0] ), $rsets[0],
  66         "Default minimum grouping found for biggest group" );
  67 $result->record_grouping( [ qw/ 1 α δ A B C P S T / ] );
  68 my %classes = (
  69         α => 'source',
  70         3 => 'source',
  71         4 => 'source' );
  72 foreach my $gp ( $result->groupings ) {
  73         map { my $c = $classes{$_} || 'copy'; $result->set_class( $_, $c ) } @$gp;
  74 }
  75 foreach my $gp ( $result->groupings ) {
  76         foreach my $wit ( @$gp ) {
  77                 my $expected = $classes{$wit} || 'copy';
  78                 is( $result->class( $wit ), $expected, "Got expected witness class for $wit" );
  79         }
  80 }
  81
  82 # Now write it out to JSON
  83 my $struct = $result->TO_JSON;
  84 my $newresult = Text::Tradition::Analysis::Result->new( $struct );
  85 is( $result->object_key, $newresult->object_key,
  86         "Object key stayed constant on export/import" );
  87 my $problem = Text::Tradition::Analysis::Result->new( graph => $sitgraph, setlist => $sets );
  88 is( $problem->object_key, $result->object_key,
  89         "Object key stayed constant for newly created problem" );
  90 }
  91
  92
  93
  94
  95 1;