[scpubgit/stemmatology.git] / analysis / 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->enable_stemmata;
$tradition->add_stemma( 'dotfile' => 't/data/besoin.dot' );

# Run the analysis of the tradition
## TODO Make proper test db
my $calcdsn = 'dbi:SQLite:dbname=t/data/analysis.db';

my %expected = (
    2 => 'type1',
    3 => 'genealogical',
    28 => 'genealogical',
    39 => 'genealogical',
    62 => 'type1',
    63 => 'type1',
    73 => 'reverted',
    76 => 'genealogical',
    91 => 'conflict',
    93 => 'genealogical',
    94 => 'genealogical',
    99 => 'reverted',
    110 => 'type1',
    117 => 'type1',
    136 => 'reverted',
    142 => 'conflict',
    155 => 'genealogical',
    170 => 'genealogical',
    182 => 'type1',
    205 => 'genealogical',
    219 => 'genealogical',
    239 => 'genealogical',
    244 => 'genealogical',
    245 => 'type1',
    251 => 'genealogical',
    252 => 'genealogical',
    293 => 'genealogical',
    295 => 'genealogical',
    309 => 'genealogical',
    310 => 'type1',
    314 => 'type1',
    315 => 'type1',
    317 => 'reverted',
    318 => 'genealogical',
    319 => 'genealogical',
    324 => 'type1',
    328 => 'reverted',
    334 => 'type1',
    335 => 'genealogical',
    350 => 'reverted',
    361 => 'reverted',
    367 => 'type1',
    370 => 'type1',
    382 => 'reverted',
    385 => 'reverted',
    406 => 'genealogical',
    413 => 'genealogical',
    417 => 'type1',
    418 => 'reverted',
    459 => 'type1',
    493 => 'genealogical',
    497 => 'reverted',
    499 => 'type1',
    500 => 'reverted',
    515 => 'reverted',
    556 => 'type1',
    558 => 'conflict',
    597 => 'type1',
    615 => 'type1',
    617 => 'type1',
    632 => 'genealogical',
    634 => 'genealogical',
    636 => 'genealogical',
    685 => 'genealogical',
    737 => 'genealogical',
    742 => 'reverted',
    743 => 'reverted',
    744 => 'reverted',
    745 => 'type1',
    746 => 'type1',
    747 => 'type1',
    757 => 'type1',
    762 => 'type1',
    763 => 'type1',
    777 => 'reverted',
    780 => 'genealogical',
    802 => 'type1',
    803 => 'type1',
    815 => 'type1',
    837 => 'genealogical',
    854 => 'type1',
    855 => 'type1',
    856 => 'type1',
    857 => 'type1',
    858 => 'type1',
    859 => 'type1',
    860 => 'type1',
    861 => 'type1',
    862 => 'type1',
    863 => 'type1',
    864 => 'type1',
    865 => 'type1',
    866 => 'type1',
    867 => 'type1',
    868 => 'type1',
    869 => 'type1',
    870 => 'type1',
    871 => 'type1',
    872 => 'type1',
    873 => 'type1',
    874 => 'type1',
    875 => 'type1',
    876 => 'type1',
    877 => 'type1',
    878 => 'type1',
    879 => 'type1',
    880 => 'type1',
    881 => 'type1',
    882 => 'type1',
    883 => 'type1',
    884 => 'type1',
    885 => 'type1',
    886 => 'type1',
    887 => 'type1',
    888 => 'type1',
    889 => 'type1',
    890 => 'type1',
    891 => 'type1',
    892 => 'type1',
    893 => 'type1',
    894 => 'type1',
    895 => 'type1',
    896 => 'type1',
    897 => 'conflict',
    898 => 'conflict',
    899 => 'type1',
    900 => 'type1',
    901 => 'type1',
    902 => 'type1',
    903 => 'type1',
    904 => 'type1',
    905 => 'type1',
    906 => 'type1',
    907 => 'type1',
    915 => 'type1',
    916 => 'type1',
    925 => 'genealogical',
    927 => 'type1',
    952 => 'genealogical',
    954 => 'genealogical',
    969 => 'genealogical',
    972 => 'genealogical',
    973 => 'genealogical',
    974 => 'type1',
    1003 => 'genealogical',
    1004 => 'genealogical' # check for transp
);

my %num_readings;

my @all_variant_ranks = sort { $a <=> $b } keys( %expected );
# Look through the results
my $c = $tradition->collation;
my %analysis_opts;
my $results = run_analysis( $tradition, %analysis_opts );
my @analyzed;
foreach my $row ( @{$results->{'variants'}} ) {
	push( @analyzed, $row->{id} );
	$num_readings{$row->{id}} = scalar @{$row->{'readings'}};
	my $type = 'genealogical';
	if( grep { $_->{'is_conflict'} } @{$row->{'readings'}} ) {
		$type = 'conflict';
	} elsif( grep { $_->{'is_reverted'} } @{$row->{'readings'}} ) {
		$type = 'reverted';
	}
	my $expected = $expected{$row->{'id'}};
	$expected = 'genealogical' if $expected eq 'type1';
	is( $type, $expected, "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.
	ok( !exists $row->{'unsolved'}, "Got a solution for the stated problem" );
	next if exists $row->{'unsolved'};
	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->{'source_parents'} || {};
			foreach my $p ( keys %$parents ) {
				push( @{$is_parent{$p}}, $rdg->{'readingid'} );
			}
			push( @has_no_parent, $rdg->{'readingid'} ) unless keys %$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" );
	}
}
# Check that run_analysis ran an analysis on all our known variant ranks
is_deeply( \@all_variant_ranks, \@analyzed, "Ran analysis for all expected rows" );

# Now run it again, excluding type 1 variants.
map { delete $expected{$_} if $expected{$_} eq 'type1' } keys %expected;
my @useful_variant_ranks = sort { $a <=> $b } keys( %expected );
$analysis_opts{'exclude_type1'} = 1;
@analyzed = ();
$results = run_analysis( $tradition, %analysis_opts );
foreach my $row ( @{$results->{'variants'}} ) {
	ok( !exists $row->{'unsolved'}, "Got a solution for the stated problem" );
	next if exists $row->{'unsolved'};
	push( @analyzed, $row->{id} );
	my $type = 'genealogical';
	if( grep { $_->{'is_conflict'} } @{$row->{'readings'}} ) {
		$type = 'conflict';
	} elsif( grep { $_->{'is_reverted'} } @{$row->{'readings'}} ) {
		$type = 'reverted';
	}
	is( $type, $expected{$row->{'id'}}, "Got expected genealogical result on exclude_type1 run for rank " . $row->{'id'} );
}
is_deeply( \@analyzed, \@useful_variant_ranks, "Ran analysis for all useful rows" );

# Now run it again, excluding orthography / spelling.
my @merged_exclude = qw/ 76 136 142 155 293 317 319 335 350 361 413 500 515 636 685 
	737 954 1003 /;
# 205 now conflicts; it and 493 should also have one fewer reading
$expected{205} = 'conflict';
$num_readings{205}--;
$num_readings{493}--;
map { delete $expected{$_} } @merged_exclude;
my @merged_remaining = sort { $a <=> $b } keys( %expected );
$analysis_opts{'merge_types'} = [ qw/ orthographic spelling / ];
@analyzed = ();
$results = run_analysis( $tradition, %analysis_opts );
foreach my $row ( @{$results->{'variants'}} ) {
	push( @analyzed, $row->{id} );
	ok( !exists $row->{'unsolved'}, "Got a solution for the stated problem" );
	next if exists $row->{'unsolved'};
	my $type = 'genealogical';
	if( grep { $_->{'is_conflict'} } @{$row->{'readings'}} ) {
		$type = 'conflict';
	} elsif( grep { $_->{'is_reverted'} } @{$row->{'readings'}} ) {
		$type = 'reverted';
	}
	is( $type, $expected{$row->{'id'}}, "Got expected genealogical result on merge_types run for rank " . $row->{'id'} );
	is( scalar @{$row->{'readings'}}, $num_readings{$row->{id}}, "Got expected number of readings during merge" );
}
is_deeply( \@analyzed, \@merged_remaining, "Ran analysis for all useful unmerged rows" );

done_testing();
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' );
951ddfe8	18	$tradition->enable_stemmata;
f00cefe8	19	$tradition->add_stemma( 'dotfile' => 't/data/besoin.dot' );
	20
	21	# Run the analysis of the tradition
7e17346f	22	## TODO Make proper test db
7e17346f	23	my $calcdsn = 'dbi:SQLite:dbname=t/data/analysis.db';
f00cefe8	24
f00cefe8	25	my %expected = (
e6823346	26	2 => 'type1',
	27	3 => 'genealogical',
	28	28 => 'genealogical',
	29	39 => 'genealogical',
	30	62 => 'type1',
	31	63 => 'type1',
	32	73 => 'reverted',
	33	76 => 'genealogical',
	34	91 => 'conflict',
	35	93 => 'genealogical',
	36	94 => 'genealogical',
	37	99 => 'reverted',
	38	110 => 'type1',
	39	117 => 'type1',
	40	136 => 'reverted',
	41	142 => 'conflict',
	42	155 => 'genealogical',
	43	170 => 'genealogical',
	44	182 => 'type1',
	45	205 => 'genealogical',
	46	219 => 'genealogical',
	47	239 => 'genealogical',
	48	244 => 'genealogical',
	49	245 => 'type1',
	50	251 => 'genealogical',
	51	252 => 'genealogical',
	52	293 => 'genealogical',
	53	295 => 'genealogical',
	54	309 => 'genealogical',
	55	310 => 'type1',
	56	314 => 'type1',
	57	315 => 'type1',
	58	317 => 'reverted',
	59	318 => 'genealogical',
	60	319 => 'genealogical',
	61	324 => 'type1',
	62	328 => 'reverted',
	63	334 => 'type1',
	64	335 => 'genealogical',
	65	350 => 'reverted',
	66	361 => 'reverted',
	67	367 => 'type1',
	68	370 => 'type1',
	69	382 => 'reverted',
	70	385 => 'reverted',
	71	406 => 'genealogical',
	72	413 => 'genealogical',
	73	417 => 'type1',
	74	418 => 'reverted',
	75	459 => 'type1',
	76	493 => 'genealogical',
	77	497 => 'reverted',
	78	499 => 'type1',
	79	500 => 'reverted',
	80	515 => 'reverted',
	81	556 => 'type1',
	82	558 => 'conflict',
	83	597 => 'type1',
	84	615 => 'type1',
	85	617 => 'type1',
	86	632 => 'genealogical',
	87	634 => 'genealogical',
	88	636 => 'genealogical',
	89	685 => 'genealogical',
90	737 => 'genealogical',
91	742 => 'reverted',
92	743 => 'reverted',
93	744 => 'reverted',
94	745 => 'type1',
95	746 => 'type1',
96	747 => 'type1',
97	757 => 'type1',
98	762 => 'type1',
99	763 => 'type1',
100	777 => 'reverted',
101	780 => 'genealogical',
102	802 => 'type1',
103	803 => 'type1',
104	815 => 'type1',
105	837 => 'genealogical',
106	854 => 'type1',
107	855 => 'type1',
108	856 => 'type1',
109	857 => 'type1',
110	858 => 'type1',
111	859 => 'type1',
112	860 => 'type1',
113	861 => 'type1',
114	862 => 'type1',
115	863 => 'type1',
116	864 => 'type1',
117	865 => 'type1',
118	866 => 'type1',
119	867 => 'type1',
120	868 => 'type1',
121	869 => 'type1',
122	870 => 'type1',
123	871 => 'type1',
124	872 => 'type1',
125	873 => 'type1',
126	874 => 'type1',
127	875 => 'type1',
128	876 => 'type1',
129	877 => 'type1',
130	878 => 'type1',
131	879 => 'type1',
132	880 => 'type1',
133	881 => 'type1',
134	882 => 'type1',
135	883 => 'type1',
136	884 => 'type1',
137	885 => 'type1',
138	886 => 'type1',
139	887 => 'type1',
140	888 => 'type1',
141	889 => 'type1',
142	890 => 'type1',
143	891 => 'type1',
144	892 => 'type1',
145	893 => 'type1',
146	894 => 'type1',
147	895 => 'type1',
148	896 => 'type1',
149	897 => 'conflict',
150	898 => 'conflict',
151	899 => 'type1',
152	900 => 'type1',
153	901 => 'type1',
154	902 => 'type1',
155	903 => 'type1',
156	904 => 'type1',
157	905 => 'type1',
158	906 => 'type1',
159	907 => 'type1',
160	915 => 'type1',
161	916 => 'type1',
162	925 => 'genealogical',
163	927 => 'type1',
164	952 => 'genealogical',
165	954 => 'genealogical',
166	969 => 'genealogical',
167	972 => 'genealogical',
168	973 => 'genealogical',
169	974 => 'type1',
170	1003 => 'genealogical',
171	1004 => 'genealogical' # check for transp
f00cefe8	172	);
f00cefe8	173
e6823346	174	my %num_readings;
	175
	176	my @all_variant_ranks = sort { $a <=> $b } keys( %expected );
f00cefe8	177	# Look through the results
f00cefe8	178	my $c = $tradition->collation;
a745c3d9	179	my %analysis_opts;
e6823346	180	my $results = run_analysis( $tradition, %analysis_opts );
e6823346	181	my @analyzed;
f00cefe8	182	foreach my $row ( @{$results->{'variants'}} ) {
e6823346	183	push( @analyzed, $row->{id} );
	184	$num_readings{$row->{id}} = scalar @{$row->{'readings'}};
	185	my $type = 'genealogical';
	186	if( grep { $_->{'is_conflict'} } @{$row->{'readings'}} ) {
	187	$type = 'conflict';
	188	} elsif( grep { $_->{'is_reverted'} } @{$row->{'readings'}} ) {
	189	$type = 'reverted';
	190	}
	191	my $expected = $expected{$row->{'id'}};
	192	$expected = 'genealogical' if $expected eq 'type1';
	193	is( $type, $expected, "Got expected genealogical result for rank " . $row->{'id'} );
	194	# If the row is genealogical, there should be one reading with no parents,
	195	# every reading should independently occur exactly once, and the total
	196	# number of changes + maybe-changes should equal the total number of
	197	# readings who have that one as a parent.
a745c3d9	198	ok( !exists $row->{'unsolved'}, "Got a solution for the stated problem" );
a745c3d9	199	next if exists $row->{'unsolved'};
e6823346	200	if( $row->{'genealogical'} ) {
	201	# Make the mapping of parent -> child readings
	202	my %is_parent;
	203	my @has_no_parent;
f00cefe8	204	foreach my $rdg ( @{$row->{'readings'}} ) {
e6823346	205	my $parents = $rdg->{'source_parents'} \|\| {};
	206	foreach my $p ( keys %$parents ) {
	207	push( @{$is_parent{$p}}, $rdg->{'readingid'} );
f00cefe8	208	}
e6823346	209	push( @has_no_parent, $rdg->{'readingid'} ) unless keys %$parents;
f00cefe8	210	}
e6823346	211	# Test some stuff
	212	foreach my $rdg ( @{$row->{'readings'}} ) {
	213	is( @{$rdg->{'independent_occurrence'}}, 1,
	214	"Genealogical reading originates exactly once" );
f00cefe8	215	}
e6823346	216	is( @has_no_parent, 1, "Only one genealogical reading lacks a parent" );
f00cefe8	217	}
f00cefe8	218	}
e6823346	219	# Check that run_analysis ran an analysis on all our known variant ranks
	220	is_deeply( \@all_variant_ranks, \@analyzed, "Ran analysis for all expected rows" );
	221
	222	# Now run it again, excluding type 1 variants.
	223	map { delete $expected{$_} if $expected{$_} eq 'type1' } keys %expected;
	224	my @useful_variant_ranks = sort { $a <=> $b } keys( %expected );
	225	$analysis_opts{'exclude_type1'} = 1;
	226	@analyzed = ();
	227	$results = run_analysis( $tradition, %analysis_opts );
	228	foreach my $row ( @{$results->{'variants'}} ) {
a745c3d9	229	ok( !exists $row->{'unsolved'}, "Got a solution for the stated problem" );
a745c3d9	230	next if exists $row->{'unsolved'};
e6823346	231	push( @analyzed, $row->{id} );
	232	my $type = 'genealogical';
	233	if( grep { $_->{'is_conflict'} } @{$row->{'readings'}} ) {
	234	$type = 'conflict';
	235	} elsif( grep { $_->{'is_reverted'} } @{$row->{'readings'}} ) {
	236	$type = 'reverted';
	237	}
	238	is( $type, $expected{$row->{'id'}}, "Got expected genealogical result on exclude_type1 run for rank " . $row->{'id'} );
	239	}
	240	is_deeply( \@analyzed, \@useful_variant_ranks, "Ran analysis for all useful rows" );
	241
	242	# Now run it again, excluding orthography / spelling.
	243	my @merged_exclude = qw/ 76 136 142 155 293 317 319 335 350 361 413 500 515 636 685
	244	737 954 1003 /;
	245	# 205 now conflicts; it and 493 should also have one fewer reading
	246	$expected{205} = 'conflict';
	247	$num_readings{205}--;
	248	$num_readings{493}--;
	249	map { delete $expected{$_} } @merged_exclude;
	250	my @merged_remaining = sort { $a <=> $b } keys( %expected );
	251	$analysis_opts{'merge_types'} = [ qw/ orthographic spelling / ];
	252	@analyzed = ();
	253	$results = run_analysis( $tradition, %analysis_opts );
	254	foreach my $row ( @{$results->{'variants'}} ) {
	255	push( @analyzed, $row->{id} );
a745c3d9	256	ok( !exists $row->{'unsolved'}, "Got a solution for the stated problem" );
a745c3d9	257	next if exists $row->{'unsolved'};
e6823346	258	my $type = 'genealogical';
	259	if( grep { $_->{'is_conflict'} } @{$row->{'readings'}} ) {
	260	$type = 'conflict';
	261	} elsif( grep { $_->{'is_reverted'} } @{$row->{'readings'}} ) {
	262	$type = 'reverted';
	263	}
	264	is( $type, $expected{$row->{'id'}}, "Got expected genealogical result on merge_types run for rank " . $row->{'id'} );
	265	is( scalar @{$row->{'readings'}}, $num_readings{$row->{id}}, "Got expected number of readings during merge" );
	266	}
	267	is_deeply( \@analyzed, \@merged_remaining, "Ran analysis for all useful unmerged rows" );
	268
	269	done_testing();