Commit | Line | Data |
f00cefe8 |
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. |
fae07016 |
117 | # HACK to cope with formerly unuseful rows |
118 | unless( exists $expected{$row->{'id'}} ) { |
119 | $expected{$row->{'id'}} = 1; |
120 | } |
adc08836 |
121 | my $gen_bool = $row->{'genealogical'} ? 1 : ''; |
122 | is( $gen_bool, $expected{$row->{'id'}}, |
f00cefe8 |
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 ( @$parents ) { |
135 | push( @{$is_parent{$p}}, $rdg->{'readingid'} ); |
136 | } |
137 | push( @has_no_parent, $rdg->{'readingid'} ) unless @$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; |