add facilities for removing 'collated' relationship, and for annotation
[scpubgit/stemmatology.git] / t / stemma.t
1 #!/usr/bin/perl
2
3 use strict; use warnings;
4 use File::Which;
5 use Test::More;
6 use lib 'lib';
7 use Text::Tradition;
8 use Text::Tradition::StemmaUtil qw/ character_input phylip_pars parse_newick /;
9 use XML::LibXML;
10 use XML::LibXML::XPathContext;
11
12 my $datafile = 't/data/Collatex-16.xml'; #TODO need other test data
13
14 my $tradition = Text::Tradition->new( 
15     'name'  => 'inline', 
16     'input' => 'CollateX',
17     'file'  => $datafile,
18     );
19 # Set up some relationships
20 my $c = $tradition->collation;
21 $c->add_relationship( 'n25', 'n26', { 'type' => 'spelling' } );
22 $c->add_relationship( 'n9', 'n23', { 'type' => 'spelling' } );
23 $c->add_relationship( 'n8', 'n13', { 'type' => 'spelling' } );
24 $c->calculate_ranks();
25
26 my $stemma = $tradition->add_stemma( dotfile => 't/data/simple.dot' );
27
28 # Test for object creation
29 ok( $stemma->isa( 'Text::Tradition::Stemma' ), 'Got the right sort of object' );
30 is( $stemma->graph, '1-2,1-A,2-B,2-C', "Got the correct graph" );
31
32 # Test for character matrix creation
33 my $mstr = character_input( $c->make_alignment_table() );
34  ## check number of rows
35 my @mlines = split( "\n", $mstr );
36 my $msig = shift @mlines;
37 my( $rows, $chars ) = $msig =~ /(\d+)\s+(\d+)/;
38 is( $rows, 3, "Found three witnesses in char matrix" );
39  ## check number of columns
40 is( $chars, 18, "Found 18 rows plus sigla in char matrix" );
41  ## check matrix
42 my %expected = (
43         'A' => 'AAAAAAAXAAAAAAAAAA',
44         'B' => 'AXXXAAAAAABABAABAA',
45         'C' => 'AXXXAAAAABAAAAAXBB',
46         );
47 foreach my $ml ( @mlines ) {
48         my( $wit, $chars ) = split( /\s+/, $ml );
49         is( $chars, $expected{$wit}, "Row for witness $wit is correct" );
50 }
51
52 # Test that pars runs
53 SKIP: {
54     skip "pars not in path", 3 unless File::Which::which('pars');
55     my $newick = phylip_pars( $mstr );
56     ok( $newick, "pars ran successfully" );
57
58         my $trees = parse_newick( $newick );
59     # Test that we get a tree
60     is( scalar @$trees, 1, "Got a single tree" );
61     # Test that the tree has all our witnesses
62     my $tree = $trees->[0];
63     my @leaves = grep { $tree->degree( $_ ) == 1 } $tree->vertices;
64     is( scalar @leaves, 3, "All witnesses in the tree" );
65 }
66
67 # Test our dot output
68 my $display = $stemma->as_dot();
69 ok( $display =~ /digraph/, "Got a dot display graph" );
70 ok( $display !~ /hypothetical/, "Graph is display rather than edit" );
71 # Test our editable output
72 my $editable = $stemma->editable();
73 ok( $editable =~ /digraph/, "Got a dot edit graph" );
74 ok( $editable =~ /hypothetical/, "Graph contains an edit class" );
75
76 done_testing();