t/analysis.t

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5 use lib 'lib';
   6 use feature 'say';
   7 use Test::More;
   8 use Text::Tradition;
   9 use Text::Tradition::Analysis qw/ run_analysis /;
  10
  11 binmode STDOUT, ':utf8';
  12 binmode STDERR, ':utf8';
  13 eval { no warnings; binmode $DB::OUT, ':utf8'; $DB::deep = 1000 };
  14
  15 my $tradition = Text::Tradition->new(
  16         'input' => 'Self',
  17         'file' => 't/data/besoin.xml' );
  18 $tradition->add_stemma( 'dotfile' => 't/data/besoin.dot' );
  19
  20 # Hack to avoid warning
  21 $tradition->collation->add_relationship( '493,2', '493,3', {'type'=>'orthographic'} );
  22
  23 # Run the analysis of the tradition
  24 my $results = run_analysis( $tradition );
  25
  26 my %expected = (
  27     3 => 1,
  28     28 => 1,
  29     39 => 1,
  30     73 => '',
  31     76 => 1,
  32     91 => '',
  33     93 => 1,
  34     94 => 1,
  35     99 => '',
  36     136 => '',
  37     142 => '',
  38     155 => 1,
  39     170 => 1,
  40     205 => 1,
  41     219 => 1,
  42     239 => 1,
  43     244 => 1,
  44     251 => 1,
  45     252 => 1,
  46     293 => 1,
  47     295 => 1,
  48     309 => 1,
  49     317 => '',
  50     318 => 1,
  51     319 => 1,
  52     328 => '',
  53     335 => 1,
  54     350 => '',
  55     361 => '',
  56     382 => '',
  57     385 => '',
  58     406 => 1,
  59     413 => 1,
  60     418 => '',
  61     493 => 1,
  62     497 => '',
  63     500 => '',
  64     515 => '',
  65     558 => '',
  66     632 => 1,
  67     634 => 1,
  68     636 => 1,
  69     685 => 1,
  70     737 => 1,
  71     742 => '',
  72     743 => '',
  73     744 => '',
  74     777 => '',
  75     780 => 1,
  76     837 => 1,
  77     897 => '',
  78     898 => '',
  79     925 => 1,
  80     952 => 1,
  81     954 => 1,
  82     969 => 1,
  83     972 => 1,
  84     973 => 1,
  85     1003 => 1,
  86     1004 => 1,
  87     1013 => 1,
  88 );
  89
  90 # Look through the results
  91 my $display = $ARGV[0];
  92 my $c = $tradition->collation;
  93 foreach my $row ( @{$results->{'variants'}} ) {
  94         if( $display ) {
  95                 say sprintf( "=== Looking at rank %d (%s) ===", $row->{'id'},
  96                         $row->{'genealogical'} ? 'genealogical' : 'not genealogical' );
  97                 foreach my $rdg ( @{$row->{'readings'}} ) {
  98                         my $parents = $rdg->{'reading_parents'};
  99                         say sprintf( "Reading %s: %s", $rdg->{'readingid'},
 100                                 $rdg->{'conflict'} ? '(conflicted)' : '' );
 101                         if( $parents && @$parents ) {
 102                                 say "\tParent reading(s) " . join( ', ', @$parents );
 103                                 foreach my $p ( @$parents ) {
 104                                         # Is there a relationship here?
 105                                         my $rel = $c->get_relationship( $rdg->{'readingid'}, $p );
 106                                         if( $rel ) {
 107                                                 say sprintf( "\t* Relationship %s %s to parent %s",
 108                                                         $rel->type,
 109                                                         $rel->annotation ? '('.$rel->annotation.')' : '',
 110                                                         $p );
 111                                         }
 112                                 }
 113                         }
 114                         say sprintf( "\t%d independent, %d followed, %d changed, %d unknown",
 115                                 $rdg->{'independent_occurrence'}, $rdg->{'followed'},
 116                                 $rdg->{'not_followed'}, $rdg->{'follow_unknown'} );
 117                 }
 118         } else {
 119                 # If not displaying, we're testing.
 120                 # HACK to cope with formerly unuseful rows
 121                 unless( exists $expected{$row->{'id'}} ) {
 122                         $expected{$row->{'id'}} = 1;
 123                 }
 124                 my $gen_bool = $row->{'genealogical'} ? 1 : '';
 125                 is( $gen_bool, $expected{$row->{'id'}},
 126                         "Got expected genealogical result for rank " . $row->{'id'} );
 127                 # If the row is genealogical, there should be one reading with no parents,
 128                 # every reading should independently occur exactly once, and the total
 129                 # number of changes + maybe-changes should equal the total number of
 130                 # readings who have that one as a parent.
 131                 if( $row->{'genealogical'} ) {
 132                         # Make the mapping of parent -> child readings
 133                         my %is_parent;
 134                         my @has_no_parent;
 135                         foreach my $rdg ( @{$row->{'readings'}} ) {
 136                                 my $parents = $rdg->{'reading_parents'} || [];
 137                                 foreach my $p ( @$parents ) {
 138                                         push( @{$is_parent{$p}}, $rdg->{'readingid'} );
 139                                 }
 140                                 push( @has_no_parent, $rdg->{'readingid'} ) unless @$parents;
 141                         }
 142                         # Test some stuff
 143                         foreach my $rdg ( @{$row->{'readings'}} ) {
 144                                 is( $rdg->{'independent_occurrence'}, 1,
 145                                         "Genealogical reading originates exactly once" );
 146                         }
 147                         is( @has_no_parent, 1, "Only one genealogical reading lacks a parent" );
 148                 }
 149         }
 150 }
 151 done_testing() unless $display;