add JSON alignment table parsing
[scpubgit/stemmatology.git] / lib / Text / Tradition / Parser / JSON.pm
CommitLineData
a731e73a 1package Text::Tradition::Parser::JSON;
2
3use strict;
4use warnings;
5use JSON qw/ from_json /;
6
7=head1 NAME
8
9Text::Tradition::Parser::JSON
10
11=head1 SYNOPSIS
12
13 use Text::Tradition;
14
15 my $tradition = Text::Tradition->new(
16 'name' => 'my text',
17 'input' => 'JSON',
18 'string' => $json_encoded_utf8,
19 );
20
21=head1 DESCRIPTION
22
23Parser module for Text::Tradition to read a JSON alignment table format such
24as that produced by CollateX.
25
26=head1 METHODS
27
28=head2 B<parse>( $tradition, $option_hash )
29
30Takes an initialized tradition and a set of options; creates the
31appropriate nodes and edges on the graph, as well as the appropriate
32witness objects. The $option_hash must contain either a 'file' or a
33'string' argument with the JSON structure to be parsed.
34
35The structure of the JSON is thus:
36
37 { alignment => [ { witness => "SIGIL",
38 tokens => [ { t => "TEXT" }, ... ] },
39 { witness => "SIG2",
40 tokens => [ { t => "TEXT" }, ... ] },
41 ... ],
42 };
43
44
45Longer lacunae in the text, to be disregarded in cladistic analysis, may be
46represented with the meta-reading '#LACUNA#'. Multiple lacuna tags in sequence
47are collapsed into a single multi-reading lacuna.
48
49If a witness name ends in the collation's ac_label, it will be treated as
50an extra layer of the 'main' witness whose sigil it shares.
51
52=begin testing
53
54use Text::Tradition;
55binmode STDOUT, ":utf8";
56binmode STDERR, ":utf8";
57eval { no warnings; binmode $DB::OUT, ":utf8"; };
58
59use_ok( 'Text::Tradition::Parser::JSON' );
60
61open( JSFILE, 't/data/cx16.json' );
62binmode JSFILE, ':utf8';
63my @lines = <JSFILE>;
64close JSFILE;
65
66my $t = Text::Tradition->new(
67 'name' => 'json',
68 'input' => 'JSON',
69 'string' => join( '', @lines ),
70);
71
72is( ref( $t ), 'Text::Tradition', "Parsed a JSON alignment" );
73if( $t ) {
74 is( scalar $t->collation->readings, 26, "Collation has all readings" );
75 is( scalar $t->collation->paths, 32, "Collation has all paths" );
76 is( scalar $t->witnesses, 3, "Collation has all witnesses" );
77}
78
79=end testing
80
81=cut
82
83sub parse {
84 my( $tradition, $opts ) = @_;
85 my $c = $tradition->collation;
86
87 my $table = from_json( $opts->{'string'} );
88
89 # Create the witnesses
90 my @witnesses;
91 my %ac_wits; # Track these for later removal
92 foreach my $sigil ( map { $_->{'witness'} } @{$table->{'alignment'}} ) {
93 my $wit = $tradition->add_witness( 'sigil' => $sigil );
94 $wit->path( [ $c->start ] );
95 push( @witnesses, $wit );
96 my $aclabel = $c->ac_label;
97 if( $sigil =~ /^(.*)\Q$aclabel\E$/ ) {
98 $ac_wits{$1} = $wit;
99 }
100 }
101
102 # Create the readings in each row
103 my $length = exists $table->{'length'}
104 ? $table->{'length'}
105 : scalar @{$table->{'alignment'}->[0]->{'tokens'}};
106
107 foreach my $idx ( 0 .. $length - 1 ) {
108 my @tokens = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
109 my @readings = make_nodes( $c, $idx, @tokens );
110 foreach my $w ( 0 .. $#readings ) {
111 # push the appropriate node onto the appropriate witness path
112 my $rdg = $readings[$w];
113 if( $rdg ) {
114 my $wit = $witnesses[$w];
115 push( @{$wit->path}, $rdg );
116 } # else skip it for empty readings.
117 }
118 }
119
120 # Collapse our lacunae into a single node and
121 # push the end node onto all paths.
122 $c->end->rank( $length );
123 foreach my $wit ( @witnesses ) {
124 my $p = $wit->path;
125 my $last_rdg = shift @$p;
126 my $new_p = [ $last_rdg ];
127 foreach my $rdg ( @$p ) {
128 # Omit the reading if we are in a lacuna already.
129 next if $rdg->is_lacuna && $last_rdg->is_lacuna;
130 # Save the reading otherwise.
131 push( @$new_p, $rdg );
132 $last_rdg = $rdg;
133 }
134 push( @$new_p, $c->end );
135 $wit->path( $new_p );
136 }
137
138 # Fold any a.c. witnesses into their main witness objects, and
139 # delete the independent a.c. versions.
140 foreach my $a ( keys %ac_wits ) {
141 my $main_wit = $tradition->witness( $a );
142 next unless $main_wit;
143 my $ac_wit = $ac_wits{$a};
144 $main_wit->uncorrected_path( $ac_wit->path );
145 $tradition->del_witness( $ac_wit );
146 }
147
148 # Join up the paths.
149 $c->make_witness_paths;
150 # Delete our unused lacuna nodes.
151 foreach my $rdg ( grep { $_->is_lacuna } $c->readings ) {
152 $c->del_reading( $rdg ) unless $c->reading_witnesses( $rdg );
153 }
154}
155
156=head2 make_nodes( $collation, $index, @tokenlist )
157
158Create readings from the unique tokens in @tokenlist, and set their rank to
159$index. Returns an array of readings of the same size as the original @tokenlist.
160
161=cut
162
163sub make_nodes {
164 my( $c, $idx, @tokens ) = @_;
165 my %unique;
166 my $ctr = 1;
167 foreach my $t ( @tokens ) {
168 next unless $t;
169 my $id = join( ',', $idx, $ctr++ );
170 my $rdg = Text::Tradition::Collation::Reading->new(
171 'id' => $id, 'json' => $t, 'collation' => $c );
172 my $comptoken = $c->collapse_punctuation ? $rdg->text
173 : $rdg->punctuated_form;
174 $unique{$comptoken} = $rdg;
175 $t->{'comptoken'} = $comptoken;
176 }
177 map { $c->add_reading( $_ ) } values( %unique );
178 return map { $_ && $unique{$_->{'comptoken'}} } @tokens;
179}
180
1811;
182
183=head1 LICENSE
184
185This package is free software and is provided "as is" without express
186or implied warranty. You can redistribute it and/or modify it under
187the same terms as Perl itself.
188
189=head1 AUTHOR
190
191Tara L Andrews E<lt>aurum@cpan.orgE<gt>