Commit | Line | Data |
b49c4318 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; use warnings; |
b22576c6 |
4 | use Test::More; |
b49c4318 |
5 | use lib 'lib'; |
bfcbcecb |
6 | use File::Which; |
8e1394aa |
7 | use Text::Tradition; |
b49c4318 |
8 | use XML::LibXML; |
9 | use XML::LibXML::XPathContext; |
10 | |
bfcbcecb |
11 | plan skip_all => 'Need Graphviz installed to test graphs' |
12 | unless File::Which::which( 'dot' ); |
13 | |
b49c4318 |
14 | my $datafile = 't/data/Collatex-16.xml'; |
15 | |
7035e3a6 |
16 | my $tradition = Text::Tradition->new( |
17 | 'name' => 'inline', |
18 | 'input' => 'CollateX', |
19 | 'file' => $datafile, |
20 | ); |
8e1394aa |
21 | my $collation = $tradition->collation; |
b49c4318 |
22 | |
23 | # Test the svg creation |
24 | my $parser = XML::LibXML->new(); |
25 | $parser->load_ext_dtd( 0 ); |
8e1394aa |
26 | my $svg = $parser->parse_string( $collation->as_svg() ); |
b49c4318 |
27 | is( $svg->documentElement->nodeName(), 'svg', 'Got an svg document' ); |
28 | |
29 | # Test for the correct number of nodes in the SVG |
30 | my $svg_xpc = XML::LibXML::XPathContext->new( $svg->documentElement() ); |
31 | $svg_xpc->registerNs( 'svg', 'http://www.w3.org/2000/svg' ); |
32 | my @svg_nodes = $svg_xpc->findnodes( '//svg:g[@class="node"]' ); |
3265b0ce |
33 | is( scalar @svg_nodes, 26, "Correct number of nodes in the graph" ); |
b49c4318 |
34 | |
35 | # Test for the correct number of edges |
36 | my @svg_edges = $svg_xpc->findnodes( '//svg:g[@class="edge"]' ); |
3265b0ce |
37 | is( scalar @svg_edges, 32, "Correct number of edges in the graph" ); |
b49c4318 |
38 | |
b22576c6 |
39 | # Test svg creation for a subgraph |
0ecb975c |
40 | my $part_svg = $parser->parse_string( $collation->as_svg( { from => 15 } ) ); # start, no end |
b22576c6 |
41 | is( $part_svg->documentElement->nodeName(), 'svg', "Got an svg subgraph to end" ); |
42 | my $part_xpc = XML::LibXML::XPathContext->new( $part_svg->documentElement() ); |
43 | $part_xpc->registerNs( 'svg', 'http://www.w3.org/2000/svg' ); |
44 | @svg_nodes = $part_xpc->findnodes( '//svg:g[@class="node"]' ); |
45 | is( scalar( @svg_nodes ), 9, |
46 | "Correct number of nodes in the subgraph" ); |
47 | @svg_edges = $part_xpc->findnodes( '//svg:g[@class="edge"]' ); |
48 | is( scalar( @svg_edges ), 10, |
49 | "Correct number of edges in the subgraph" ); |
b22576c6 |
50 | |
0ecb975c |
51 | $part_svg = $parser->parse_string( $collation->as_svg( { from => 10, to => 13 } ) ); # start, no end |
b22576c6 |
52 | is( $part_svg->documentElement->nodeName(), 'svg', "Got an svg subgraph in the middle" ); |
53 | $part_xpc = XML::LibXML::XPathContext->new( $part_svg->documentElement() ); |
54 | $part_xpc->registerNs( 'svg', 'http://www.w3.org/2000/svg' ); |
55 | @svg_nodes = $part_xpc->findnodes( '//svg:g[@class="node"]' ); |
56 | is( scalar( @svg_nodes ), 9, |
57 | "Correct number of nodes in the subgraph" ); |
58 | @svg_edges = $part_xpc->findnodes( '//svg:g[@class="edge"]' ); |
59 | is( scalar( @svg_edges ), 11, |
60 | "Correct number of edges in the subgraph" ); |
61 | |
62 | |
0ecb975c |
63 | $part_svg = $parser->parse_string( $collation->as_svg( { to => 5 } ) ); # start, no end |
b22576c6 |
64 | is( $part_svg->documentElement->nodeName(), 'svg', "Got an svg subgraph from start" ); |
65 | $part_xpc = XML::LibXML::XPathContext->new( $part_svg->documentElement() ); |
66 | $part_xpc->registerNs( 'svg', 'http://www.w3.org/2000/svg' ); |
67 | @svg_nodes = $part_xpc->findnodes( '//svg:g[@class="node"]' ); |
68 | is( scalar( @svg_nodes ), 7, |
69 | "Correct number of nodes in the subgraph" ); |
70 | @svg_edges = $part_xpc->findnodes( '//svg:g[@class="edge"]' ); |
71 | is( scalar( @svg_edges ), 7, |
72 | "Correct number of edges in the subgraph" ); |
73 | |
74 | SKIP: { |
75 | skip "lemmatization disabled for now", 1; |
76 | # Test for the correct common nodes |
77 | my @common_nodes = ( '#START#' ); |
78 | push( @common_nodes, qw/ n1 n5 n6 n7 n12 n16 n19 n20 n27 / ); |
79 | my @expected_nodes = map { [ $_, 1 ] } @common_nodes; |
80 | foreach my $idx ( qw/2 3 4 8 10 11 13 16 17 18/ ) { |
81 | splice( @expected_nodes, $idx, 0, [ "node_null", undef ] ); |
b49c4318 |
82 | } |
b22576c6 |
83 | my @active_nodes = $collation->lemma_readings(); |
84 | subtest 'Initial common points' => \&compare_active; |
85 | my $string = '# when ... ... ... showers sweet with ... fruit ... ... of ... has pierced ... ... ... #'; |
86 | is( make_text( @active_nodes ), $string, "Got the right starting text" ); |
87 | |
88 | sub compare_active { |
89 | is( scalar( @active_nodes ), scalar ( @expected_nodes ), |
90 | "Arrays are same length" ); |
91 | |
92 | foreach ( 0 .. scalar(@active_nodes)-1 ) { |
93 | is( $active_nodes[$_]->[1], $expected_nodes[$_]->[1], |
94 | "Element has same toggle value" ); |
95 | if( defined $active_nodes[$_]->[1] ) { |
96 | is( $active_nodes[$_]->[0], $expected_nodes[$_]->[0], |
97 | "Active or toggled element has same node name " |
98 | . $active_nodes[$_]->[0] ); |
99 | } |
100 | } |
b49c4318 |
101 | } |
b22576c6 |
102 | |
103 | sub make_text { |
104 | my @words; |
105 | foreach my $n ( @_ ) { |
106 | if( $n->[1] ) { |
107 | push( @words, $collation->reading( $n->[0] )->text ); |
108 | } elsif ( !defined $n->[1] ) { |
109 | push( @words, '...' ); |
110 | } |
111 | } |
112 | return join( ' ', @words ); |
113 | } |
114 | |
115 | # Test that the common nodes are marked common |
116 | foreach my $cn ( @common_nodes ) { |
117 | ok( $collation->reading( $cn )->is_common, "Node $cn is marked common" ); |
118 | } |
119 | |
120 | # Test the manuscript paths |
121 | my $wit_a = '# when april with his showers sweet with fruit the drought of march has pierced unto the root #'; |
122 | my $wit_b = '# when showers sweet with april fruit the march of drought has pierced to the root #'; |
123 | my $wit_c = '# when showers sweet with april fruit teh drought of march has pierced teh rood #'; |
124 | is( join( ' ', @{$tradition->witness( "A" )->text} ), $wit_a, "Correct path for witness A" ); |
125 | is( join( ' ', @{$tradition->witness( "B" )->text} ), $wit_b, "Correct path for witness B" ); |
126 | is( join( ' ', @{$tradition->witness( "C" )->text} ), $wit_c, "Correct path for witness C" ); |
127 | |
128 | # Test the transposition identifiers |
129 | my $transposition_pools = [ [ 'n2', 'n11' ], [ 'n14', 'n18' ], |
130 | [ 'n17', 'n15' ] ]; |
131 | my $transposed_nodes = { 'n2' => $transposition_pools->[0], |
132 | 'n11' => $transposition_pools->[0], |
133 | 'n14' => $transposition_pools->[1], |
134 | 'n15' => $transposition_pools->[2], |
135 | 'n17' => $transposition_pools->[2], |
136 | 'n18' => $transposition_pools->[1], |
137 | }; |
138 | |
139 | my $real_transposed_nodes = {}; |
140 | foreach my $r ( $collation->readings ) { |
141 | my @same = map { $_->name } @{$r->same_as}; |
142 | $real_transposed_nodes->{ $r->name } = \@same if @same > 1; |
143 | } |
144 | |
145 | is_deeply( $real_transposed_nodes, $transposed_nodes, "Found the right transpositions" ); |
146 | |
147 | # Test turning on a node |
148 | my @off = $collation->toggle_reading( 'n21' ); |
149 | $expected_nodes[ 16 ] = [ "n21", 1 ]; |
150 | @active_nodes = $collation->lemma_readings( @off ); |
151 | subtest 'Turned on node for new location' => \&compare_active; |
152 | $string = '# when ... ... ... showers sweet with ... fruit ... ... of ... has pierced unto ... ... #'; |
153 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
154 | |
155 | # Test the toggling effects of same-column |
156 | @off = $collation->toggle_reading( 'n22' ); |
157 | splice( @expected_nodes, 16, 1, ( [ "n21", 0 ], [ "n22", 1 ] ) ); |
158 | @active_nodes = $collation->lemma_readings( @off ); |
159 | subtest 'Turned on other node in that location' => \&compare_active; |
160 | $string = '# when ... ... ... showers sweet with ... fruit ... ... of ... has pierced to ... ... #'; |
161 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
162 | |
163 | # Test the toggling effects of transposition |
164 | @off = $collation->toggle_reading( 'n14' ); |
165 | # Add the turned on node |
166 | $expected_nodes[ 11 ] = [ "n14", 1 ]; |
167 | # Remove the 'off' for the previous node |
168 | splice( @expected_nodes, 16, 1 ); |
169 | @active_nodes = $collation->lemma_readings( @off ); |
170 | subtest 'Turned on transposition node' => \&compare_active; |
171 | $string = '# when ... ... ... showers sweet with ... fruit ... drought of ... has pierced to ... ... #'; |
172 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
173 | |
174 | @off = $collation->toggle_reading( 'n18' ); |
175 | # Toggle on the new node |
176 | $expected_nodes[ 13 ] = [ "n18", 1 ]; |
177 | # Toggle off the transposed node |
178 | $expected_nodes[ 11 ] = [ "n14", undef ]; |
179 | @active_nodes = $collation->lemma_readings( @off ); |
180 | subtest 'Turned on that node\'s partner' => \&compare_active; |
181 | $string = '# when ... ... ... showers sweet with ... fruit ... ... of drought has pierced to ... ... #'; |
182 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
183 | |
184 | @off = $collation->toggle_reading( 'n14' ); |
185 | # Toggle on the new node |
186 | $expected_nodes[ 11 ] = [ "n14", 1 ]; |
187 | # Toggle off the transposed node |
188 | $expected_nodes[ 13 ] = [ "n18", undef ]; |
189 | @active_nodes = $collation->lemma_readings( @off ); |
190 | subtest 'Turned on the original node' => \&compare_active; |
191 | $string = '# when ... ... ... showers sweet with ... fruit ... drought of ... has pierced to ... ... #'; |
192 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
193 | |
194 | @off = $collation->toggle_reading( 'n15' ); |
195 | # Toggle on the new node, and off with the old |
196 | splice( @expected_nodes, 11, 1, [ "n14", 0 ], [ "n15", 1 ] ); |
197 | @active_nodes = $collation->lemma_readings( @off ); |
198 | subtest 'Turned on the colocated node' => \&compare_active; |
199 | $string = '# when ... ... ... showers sweet with ... fruit ... march of ... has pierced to ... ... #'; |
200 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
201 | |
202 | @off = $collation->toggle_reading( 'n3' ); |
203 | # Toggle on the new node |
204 | splice( @expected_nodes, 3, 1, [ "n3", 1 ] ); |
205 | # Remove the old toggle-off |
206 | splice( @expected_nodes, 11, 1 ); |
207 | @active_nodes = $collation->lemma_readings( @off ); |
208 | subtest 'Turned on a singleton node' => \&compare_active; |
209 | $string = '# when ... with ... showers sweet with ... fruit ... march of ... has pierced to ... ... #'; |
210 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
211 | |
212 | @off = $collation->toggle_reading( 'n3' ); |
213 | # Toggle off this node |
214 | splice( @expected_nodes, 3, 1, [ "n3", 0 ] ); |
215 | @active_nodes = $collation->lemma_readings( @off ); |
216 | subtest 'Turned off a singleton node' => \&compare_active; |
217 | $string = '# when ... ... showers sweet with ... fruit ... march of ... has pierced to ... ... #'; |
218 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
219 | |
220 | @off = $collation->toggle_reading( 'n21' ); |
221 | splice( @expected_nodes, 16, 1, ["n22", 0 ], [ "n21", 1 ] ); |
222 | @active_nodes = $collation->lemma_readings( @off ); |
223 | subtest 'Turned on another node after singleton switchoff' => \&compare_active; |
224 | $string = '# when ... ... showers sweet with ... fruit ... march of ... has pierced unto ... ... #'; |
225 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
226 | |
227 | # Now start testing some position identifiers |
228 | # 2. 'april with his' have no colocated |
229 | # 3. 'april' 2 has no colocated |
230 | # 4. 'teh' and 'the' |
231 | # 5. 'drought' & 'march' |
232 | # 6. 'march' & 'drought' |
233 | # 7. 'unto' 'the' 'root'... |
234 | # 'unto can match 'to' or 'teh' |
235 | # 'the' can match 'teh' or 'rood' |
236 | # 'root' can mach 'rood' |
237 | |
238 | foreach my $cn ( @common_nodes ) { |
239 | my $cnr = $collation->reading( $cn ); |
240 | is( scalar( $collation->same_position_as( $cnr ) ), 0, "Node $cn has no colocations" ); |
241 | } |
242 | |
243 | my %expected_colocations = ( |
244 | 'n2' => [], # april |
245 | 'n3' => [], # with |
246 | 'n4' => [], # his |
247 | 'n11' => [], # april |
248 | 'n8' => [ 'n13' ], # teh -> the |
249 | 'n13' => [ 'n8' ], # the -> teh |
250 | 'n14' => [ 'n15' ], # drought -> march |
251 | 'n18' => [ 'n17' ], # drought -> march |
252 | 'n17' => [ 'n18' ], # march -> drought |
253 | 'n15' => [ 'n14' ], # march -> drought |
254 | 'n21' => [ 'n22', 'n9' ], # unto -> to, teh |
255 | 'n22' => [ 'n21', 'n9' ], # to -> unto, teh |
256 | 'n9' => [ 'n21', 'n22', 'n23' ], # teh -> unto, to, the |
257 | 'n23' => [ 'n25', 'n9' ], # the -> teh, rood |
258 | 'n25' => [ 'n23', 'n26' ], # rood -> the, root |
259 | 'n26' => [ 'n25' ], # root -> rood |
260 | ); |
261 | |
262 | foreach my $n ( keys %expected_colocations ) { |
263 | my $nr = $collation->reading( $n ); |
264 | my @colocated = sort( map { $_->name } $collation->same_position_as( $nr ) ); |
265 | is_deeply( \@colocated, $expected_colocations{$n}, "Colocated nodes for $n correct" ); |
266 | } |
267 | |
268 | # Test strict colocations |
269 | $expected_colocations{'n9'} = []; |
270 | $expected_colocations{'n21'} = ['n22']; |
271 | $expected_colocations{'n22'} = ['n21']; |
272 | $expected_colocations{'n23'} = []; |
273 | $expected_colocations{'n25'} = []; |
274 | $expected_colocations{'n26'} = []; |
275 | |
276 | foreach my $n ( keys %expected_colocations ) { |
277 | my $nr = $collation->reading( $n ); |
278 | my @colocated = sort( map { $_->name } $collation->same_position_as( $nr, 1 ) ); |
279 | is_deeply( \@colocated, $expected_colocations{$n}, "Strictly colocated nodes for $n correct" ); |
280 | } |
281 | |
282 | # Test turning on, then off, an annoyingly overlapping node |
283 | |
284 | @off = $collation->toggle_reading( 'n9' ); |
285 | # Remove the old toggle-off |
286 | splice( @expected_nodes, 16, 1 ); |
287 | splice( @expected_nodes, 17, 0, [ "n9", 1 ] ); |
288 | @active_nodes = $collation->lemma_readings( @off ); |
289 | subtest 'Turned on a node without fixed position' => \&compare_active; |
290 | $string = '# when ... ... showers sweet with ... fruit ... march of ... has pierced unto teh ... ... #'; |
291 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
292 | |
293 | @off = $collation->toggle_reading( 'n23' ); |
294 | splice( @expected_nodes, 18, 1, [ "n23", 1 ] ); |
295 | @active_nodes = $collation->lemma_readings( @off ); |
296 | subtest 'Turned on a node colocated to one without fixed position' => \&compare_active; |
297 | $string = '# when ... ... showers sweet with ... fruit ... march of ... has pierced unto teh the ... #'; |
298 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
299 | |
300 | @off = $collation->toggle_reading( 'n9' ); |
301 | splice( @expected_nodes, 17, 1, [ "n9", 0 ] ); |
302 | @active_nodes = $collation->lemma_readings( @off ); |
303 | subtest 'Turned on a node colocated to one without fixed position' => \&compare_active; |
304 | $string = '# when ... ... showers sweet with ... fruit ... march of ... has pierced unto the ... #'; |
305 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
306 | |
307 | ### Now test relationship madness. |
308 | |
309 | my( $result, @relations ) = $collation->add_relationship( 'n25', 'n23', {'type' => 'lexical'} ); # rood -> the |
310 | ok( $result, "Added relationship between nodes" ); |
311 | is( scalar @relations, 1, "Returned only the one collapse" ); |
312 | is_deeply( $relations[0], [ 'n25', 'n23' ], "Returned the correct collapse" ); |
313 | is( $collation->reading( 'n25' )->position->reference, '9,3', "Harmonized position for n25 correct" ); |
314 | is( $collation->reading( 'n23' )->position->reference, '9,3', "Harmonized position for n23 correct" ); |
315 | is( $collation->reading( 'n9' )->position->reference, '9,2', "Adjusted position for n9 correct" ); |
316 | |
317 | # Do some yucky hardcoded cleanup to undo this relationship. |
318 | $collation->reading('n25')->position->max( 4 ); |
319 | $collation->reading('n9')->position->max( 3 ); |
320 | $collation->graph->del_edge( $collation->reading('n25')->edges_to( $collation->reading('n23')) ); |
321 | |
322 | ( $result, @relations ) = $collation->add_relationship( 'n26', 'n25', {'type' => 'spelling'} ); # root -> rood |
323 | ok( $result, "Added relationship between nodes" ); |
324 | is( scalar @relations, 1, "Returned only the one collapse" ); |
325 | is_deeply( $relations[0], [ 'n26', 'n25' ], "Returned the correct collapse" ); |
326 | is( $collation->reading( 'n26' )->position->reference, '9,4', "Harmonized position for n26 correct" ); |
327 | is( $collation->reading( 'n25' )->position->reference, '9,4', "Harmonized position for n25 correct" ); |
328 | is( $collation->reading( 'n9' )->position->reference, '9,2-3', "Adjusted position for n9 correct" ); |
329 | |
330 | ( $result, @relations ) = $collation->add_relationship( 'n15', 'n9', {'type' => 'lexical'} ); # bogus march -> teh |
331 | ok( !$result, "Refused to add skewed relationship: " . $relations[0] ); |
332 | |
333 | ( $result, @relations ) = $collation->add_relationship( 'n25', 'n26', {'type' => 'spelling'} ); # root -> rood |
334 | ok( !$result, "Refused to add dupe relationship: " . $relations[0] ); |
335 | |
336 | ( $result, @relations ) = $collation->add_relationship( 'n8', 'n13', {'type' => 'spelling', 'global' => 1 } ); # teh -> the |
337 | ok( $result, "Added global relationship between nodes" ); |
338 | is( scalar @relations, 2, "Returned two relationship creations" ); |
339 | is_deeply( $relations[0], [ 'n8', 'n13' ], "Returned the original collapse" ); |
340 | is_deeply( $relations[1], [ 'n9', 'n23' ], "Returned the other collapse" ); |
341 | is( $collation->reading( 'n8' )->position->reference, '6,2', "Harmonized position for n8 correct" ); |
342 | is( $collation->reading( 'n9' )->position->reference, '9,3', "Harmonized position for n9 correct" ); |
4cdd82f1 |
343 | } |
344 | |
b49c4318 |
345 | done_testing(); |