analysis/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 TryCatch;
  10
  11 my $datafile = 't/data/Collatex-16.xml'; #TODO need other test data
  12
  13 my $tradition = Text::Tradition->new(
  14     'name'  => 'inline',
  15     'input' => 'CollateX',
  16     'file'  => $datafile,
  17     );
  18 # Set up some relationships
  19 my $c = $tradition->collation;
  20 $c->add_relationship( 'n23', 'n24', { 'type' => 'spelling' } );
  21 $c->add_relationship( 'n9', 'n10', { 'type' => 'spelling' } );
  22 $c->add_relationship( 'n12', 'n13', { 'type' => 'spelling' } );
  23 $c->calculate_ranks();
  24
  25 my $stemma = $tradition->add_stemma( dotfile => 't/data/simple.dot' );
  26
  27 # Test for object creation
  28 ok( $stemma->isa( 'Text::Tradition::Stemma' ), 'Got the right sort of object' );
  29 is( $stemma->graph, '1-2,1-A,2-B,2-C', "Got the correct graph" );
  30
  31 # Test for character matrix creation
  32 my $mstr = character_input( $tradition );
  33  ## check number of rows
  34 my @mlines = split( "\n", $mstr );
  35 my $msig = shift @mlines;
  36 my( $rows, $chars ) = $msig =~ /(\d+)\s+(\d+)/;
  37 is( $rows, 3, "Found three witnesses in char matrix" );
  38  ## check number of columns
  39 is( $chars, 18, "Found 18 rows plus sigla in char matrix" );
  40  ## check matrix
  41 my %expected = (
  42         'A' => 'AAAAAAAXAAAAAAAAAA',
  43         'B' => 'AXXXAAAAAABABAABAA',
  44         'C' => 'AXXXAAAAABAAAAAXBB',
  45         );
  46 foreach my $ml ( @mlines ) {
  47         my( $wit, $chars ) = split( /\s+/, $ml );
  48         is( $chars, $expected{$wit}, "Row for witness $wit is correct" );
  49 }
  50
  51 # Test that pars runs
  52 SKIP: {
  53         skip "pars not in path", 3 unless File::Which::which('pars');
  54         my $newick = phylip_pars( $mstr );
  55         ok( $newick, "pars ran successfully" );
  56
  57         my $trees = parse_newick( $newick );
  58         # Test that we get a tree
  59         is( scalar @$trees, 1, "Got a single tree" );
  60         # Test that the tree has all our witnesses
  61         my $tree = $trees->[0];
  62         is( scalar $tree->witnesses, 3, "All witnesses in the tree" );
  63 }
  64
  65 # Test our dot output
  66 my $display = $stemma->as_dot();
  67 like( $display, qr/^digraph \"?Stemma/, "Got a dot display graph" );
  68 ok( $display !~ /hypothetical/, "Graph is display rather than edit" );
  69 # Test our editable output
  70 my $editable = $stemma->editable();
  71 like( $editable, qr/^digraph \"?Stemma/, "Got a dot edit graph" );
  72 ok( $editable =~ /hypothetical/, "Graph contains an edit class" );
  73
  74 # Test changing the name of the Graph
  75 $editable =~ s/^(digraph )\"?Stemma\"?/$1"Simple test stemma"/;
  76 $stemma->alter_graph( $editable );
  77 is( $stemma->identifier, "Simple test stemma", "Successfully changed name of graph" );
  78
  79 # Test re-rooting of our graph
  80 try {
  81         $stemma->root_graph('D');
  82         ok( 0, "Made attempt to root stemma graph on nonexistent vertex" );
  83 } catch( Text::Tradition::Error $e ) {
  84         like( $e->message, qr/Cannot orient graph(.*)on nonexistent vertex/,
  85                 "Exception raised for attempt to root graph on nonexistent vertex" );
  86 }
  87 $stemma->root_graph( 'B' );
  88 is( $stemma->graph, '1-A,2-1,2-C,B-2',
  89         "Stemma graph successfully re-rooted on vertex B" );
  90 is( $stemma->identifier, "Simple test stemma",
  91         "Stemma identifier survived re-rooting of graph" );
  92
  93
  94 done_testing();