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 |
7e17346f |
21 | ## TODO Make proper test db |
22 | my $calcdsn = 'dbi:SQLite:dbname=t/data/analysis.db'; |
23 | my $results = run_analysis( $tradition, calcdsn => $calcdsn ); |
f00cefe8 |
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->{'reading_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. |
fae07016 |
119 | # HACK to cope with formerly unuseful rows |
120 | unless( exists $expected{$row->{'id'}} ) { |
121 | $expected{$row->{'id'}} = 1; |
122 | } |
adc08836 |
123 | my $gen_bool = $row->{'genealogical'} ? 1 : ''; |
124 | is( $gen_bool, $expected{$row->{'id'}}, |
f00cefe8 |
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'}} ) { |
428bcf0b |
135 | my $parents = $rdg->{'reading_parents'} || {}; |
136 | foreach my $p ( keys %$parents ) { |
f00cefe8 |
137 | push( @{$is_parent{$p}}, $rdg->{'readingid'} ); |
138 | } |
428bcf0b |
139 | push( @has_no_parent, $rdg->{'readingid'} ) unless keys %$parents; |
f00cefe8 |
140 | } |
141 | # Test some stuff |
142 | foreach my $rdg ( @{$row->{'readings'}} ) { |
428bcf0b |
143 | is( @{$rdg->{'independent_occurrence'}}, 1, |
f00cefe8 |
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; |