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