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