[scpubgit/stemmatology.git] / t / analysis.t

#!/usr/bin/env perl

use strict;
use warnings;
use lib 'lib';
use feature 'say';
use Test::More;
use Text::Tradition;
use Text::Tradition::Analysis qw/ run_analysis /;

binmode STDOUT, ':utf8';
binmode STDERR, ':utf8';
eval { no warnings; binmode $DB::OUT, ':utf8'; $DB::deep = 1000 };

my $tradition = Text::Tradition->new(
	'input' => 'Self',
	'file' => 't/data/besoin.xml' );
$tradition->add_stemma( 'dotfile' => 't/data/besoin.dot' );

# Hack to avoid warning
$tradition->collation->add_relationship( '493,2', '493,3', {'type'=>'orthographic'} );

# Run the analysis of the tradition
my $results = run_analysis( $tradition );

my %expected = (
    3 => 1,
    28 => 1,
    39 => 1,
    73 => '',
    76 => 1,
    91 => '',
    93 => 1,
    94 => 1,
    99 => '',
    136 => '',
    142 => '',
    155 => 1,
    170 => 1,
    205 => 1,
    219 => 1,
    239 => 1,
    244 => 1,
    251 => 1,
    252 => 1,
    293 => 1,
    295 => 1,
    309 => 1,
    317 => '',
    318 => 1,
    319 => 1,
    328 => '',
    335 => 1,
    350 => '',
    361 => '',
    382 => '',
    385 => '',
    406 => 1,
    413 => 1,
    418 => '',
    493 => 1,
    497 => '',
    500 => '',
    515 => '',
    558 => '',
    632 => 1,
    634 => 1,
    636 => 1,
    685 => 1,
    737 => 1,
    742 => '',
    743 => '',
    744 => '',
    777 => '',
    780 => 1,
    837 => 1,
    897 => '',
    898 => '',
    925 => 1,
    952 => 1,
    954 => 1,
    969 => 1,
    972 => 1,
    973 => 1,
    1003 => 1,
    1004 => 1,
    1013 => 1,
);

# Look through the results
my $display = $ARGV[0];
my $c = $tradition->collation;
foreach my $row ( @{$results->{'variants'}} ) {
	if( $display ) {
		say sprintf( "=== Looking at rank %d (%s) ===", $row->{'id'},
			$row->{'genealogical'} ? 'genealogical' : 'not genealogical' );
		foreach my $rdg ( @{$row->{'readings'}} ) {
			my $parents = $rdg->{'reading_parents'};
			say sprintf( "Reading %s: %s", $rdg->{'readingid'}, 
				$rdg->{'conflict'} ? '(conflicted)' : '' );
			if( $parents && @$parents ) {
				say "\tParent reading(s) " . join( ', ', @$parents );
				foreach my $p ( @$parents ) {
					# Is there a relationship here?
					my $rel = $c->get_relationship( $rdg->{'readingid'}, $p );
					if( $rel ) {
						say sprintf( "\t* Relationship %s %s to parent %s",
							$rel->type, 
							$rel->annotation ? '('.$rel->annotation.')' : '', 
							$p );
					}
				}
			}
			say sprintf( "\t%d independent, %d followed, %d changed, %d unknown",
				$rdg->{'independent_occurrence'}, $rdg->{'followed'}, 
				$rdg->{'not_followed'}, $rdg->{'follow_unknown'} );
		}
	} else {
		# If not displaying, we're testing.
		# HACK to cope with formerly unuseful rows
		unless( exists $expected{$row->{'id'}} ) {
			$expected{$row->{'id'}} = 1;
		}
		my $gen_bool = $row->{'genealogical'} ? 1 : '';
		is( $gen_bool, $expected{$row->{'id'}}, 
			"Got expected genealogical result for rank " . $row->{'id'} );
		# If the row is genealogical, there should be one reading with no parents,
		# every reading should independently occur exactly once, and the total
		# number of changes + maybe-changes should equal the total number of
		# readings who have that one as a parent.
		if( $row->{'genealogical'} ) {
			# Make the mapping of parent -> child readings
			my %is_parent;
			my @has_no_parent;
			foreach my $rdg ( @{$row->{'readings'}} ) {
				my $parents = $rdg->{'reading_parents'} || [];
				foreach my $p ( @$parents ) {
					push( @{$is_parent{$p}}, $rdg->{'readingid'} );
				}
				push( @has_no_parent, $rdg->{'readingid'} ) unless @$parents;
			}
			# Test some stuff
			foreach my $rdg ( @{$row->{'readings'}} ) {
				is( $rdg->{'independent_occurrence'}, 1, 
					"Genealogical reading originates exactly once" );
			}
			is( @has_no_parent, 1, "Only one genealogical reading lacks a parent" );
		}
	}
}
done_testing() unless $display;
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
adc08836	20	# Hack to avoid warning
	21	$tradition->collation->add_relationship( '493,2', '493,3', {'type'=>'orthographic'} );
	22
f00cefe8	23	# Run the analysis of the tradition
	24	my $results = run_analysis( $tradition );
	25
	26	my %expected = (
	27	3 => 1,
	28	28 => 1,
	29	39 => 1,
	30	73 => '',
	31	76 => 1,
	32	91 => '',
	33	93 => 1,
	34	94 => 1,
	35	99 => '',
	36	136 => '',
	37	142 => '',
	38	155 => 1,
	39	170 => 1,
	40	205 => 1,
	41	219 => 1,
	42	239 => 1,
	43	244 => 1,
	44	251 => 1,
	45	252 => 1,
	46	293 => 1,
	47	295 => 1,
	48	309 => 1,
	49	317 => '',
	50	318 => 1,
	51	319 => 1,
	52	328 => '',
	53	335 => 1,
	54	350 => '',
	55	361 => '',
	56	382 => '',
	57	385 => '',
	58	406 => 1,
	59	413 => 1,
	60	418 => '',
	61	493 => 1,
	62	497 => '',
	63	500 => '',
	64	515 => '',
	65	558 => '',
	66	632 => 1,
	67	634 => 1,
	68	636 => 1,
	69	685 => 1,
	70	737 => 1,
	71	742 => '',
	72	743 => '',
	73	744 => '',
	74	777 => '',
	75	780 => 1,
	76	837 => 1,
	77	897 => '',
	78	898 => '',
	79	925 => 1,
	80	952 => 1,
	81	954 => 1,
	82	969 => 1,
	83	972 => 1,
	84	973 => 1,
	85	1003 => 1,
	86	1004 => 1,
87	1013 => 1,
88	);
89
90	# Look through the results
91	my $display = $ARGV[0];
92	my $c = $tradition->collation;
93	foreach my $row ( @{$results->{'variants'}} ) {
94	if( $display ) {
95	say sprintf( "=== Looking at rank %d (%s) ===", $row->{'id'},
96	$row->{'genealogical'} ? 'genealogical' : 'not genealogical' );
97	foreach my $rdg ( @{$row->{'readings'}} ) {
98	my $parents = $rdg->{'reading_parents'};
99	say sprintf( "Reading %s: %s", $rdg->{'readingid'},
100	$rdg->{'conflict'} ? '(conflicted)' : '' );
101	if( $parents && @$parents ) {
102	say "\tParent reading(s) " . join( ', ', @$parents );
103	foreach my $p ( @$parents ) {
104	# Is there a relationship here?
105	my $rel = $c->get_relationship( $rdg->{'readingid'}, $p );
106	if( $rel ) {
107	say sprintf( "\t* Relationship %s %s to parent %s",
108	$rel->type,
109	$rel->annotation ? '('.$rel->annotation.')' : '',
110	$p );
111	}
112	}
113	}
114	say sprintf( "\t%d independent, %d followed, %d changed, %d unknown",
115	$rdg->{'independent_occurrence'}, $rdg->{'followed'},
116	$rdg->{'not_followed'}, $rdg->{'follow_unknown'} );
117	}
118	} else {
119	# If not displaying, we're testing.
fae07016	120	# HACK to cope with formerly unuseful rows
	121	unless( exists $expected{$row->{'id'}} ) {
	122	$expected{$row->{'id'}} = 1;
	123	}
adc08836	124	my $gen_bool = $row->{'genealogical'} ? 1 : '';
adc08836	125	is( $gen_bool, $expected{$row->{'id'}},
f00cefe8	126	"Got expected genealogical result for rank " . $row->{'id'} );
	127	# If the row is genealogical, there should be one reading with no parents,
	128	# every reading should independently occur exactly once, and the total
	129	# number of changes + maybe-changes should equal the total number of
	130	# readings who have that one as a parent.
	131	if( $row->{'genealogical'} ) {
	132	# Make the mapping of parent -> child readings
	133	my %is_parent;
	134	my @has_no_parent;
	135	foreach my $rdg ( @{$row->{'readings'}} ) {
	136	my $parents = $rdg->{'reading_parents'} \|\| [];
	137	foreach my $p ( @$parents ) {
	138	push( @{$is_parent{$p}}, $rdg->{'readingid'} );
	139	}
	140	push( @has_no_parent, $rdg->{'readingid'} ) unless @$parents;
	141	}
	142	# Test some stuff
	143	foreach my $rdg ( @{$row->{'readings'}} ) {
	144	is( $rdg->{'independent_occurrence'}, 1,
	145	"Genealogical reading originates exactly once" );
	146	}
	147	is( @has_no_parent, 1, "Only one genealogical reading lacks a parent" );
	148	}
	149	}
	150	}
	151	done_testing() unless $display;