[scpubgit/stemmatology.git] / lib / Text / Tradition / Parser / Tabular.pm

package Text::Tradition::Parser::Tabular;

use strict;
use warnings;
use Text::CSV_XS;

=head1 NAME

Text::Tradition::Parser::Tabular

=head1 SYNOPSIS

  use Text::Tradition;
  
  my $t_from_file = Text::Tradition->new( 
    'name' => 'my text',
    'input' => 'Tabular',
    'file' => '/path/to/collation.csv',
    'sep_char' => ','
    );
    
  my $t_from_string = Text::Tradition->new( 
    'name' => 'my text',
    'input' => 'Tabular',
    'string' => $tab_separated_collation,
    'sep_char' => "\t",
    );

=head1 DESCRIPTION

Parser module for Text::Tradition to read an alignment table format, such as CSV.

=head1 METHODS

=head2 B<parse>( $tradition, $option_hash )

Takes an initialized tradition and a set of options; creates the
appropriate nodes and edges on the graph, as well as the appropriate
witness objects.  The $option_hash must contain either a 'file' or a
'string' argument with the table to be parsed; it may also contain a 
'sep_char' argument to specify how the fields are separated.

The table should have witnesses arranged in columns, with the witness sigla
in the first row.  Empty cells are interpreted as omissions (and thus
stemmatologically relevant.) Longer lacunae in the text, to be disregarded
in cladistic analysis, may be represented by filling the appropriate cells
with the tag '#LACUNA#'.

If a witness name ends in the collation's ac_label, it will be treated as
an 'ante-correction' version of the 'main' witness whose sigil it shares.

=begin testing

use Text::Tradition;
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";
eval { no warnings; binmode $DB::OUT, ":utf8"; };

my $csv = 't/data/florilegium.csv';
my $t = Text::Tradition->new( 
    'name'  => 'inline', 
    'input' => 'Tabular',
    'file'  => $csv,
    'sep_char' => ',',
    );

is( ref( $t ), 'Text::Tradition', "Parsed florilegium CSV file" );

### TODO Check these figures
if( $t ) {
    is( scalar $t->collation->readings, 311, "Collation has all readings" );
    is( scalar $t->collation->paths, 361, "Collation has all paths" );
    is( scalar $t->witnesses, 13, "Collation has all witnesses" );
}

# Check that we have the right witnesses
my %seen_wits;
map { $seen_wits{$_} = 0 } qw/ A B C D E F G H K P Q S T /;
foreach my $wit ( $t->witnesses ) {
	$seen_wits{$wit->sigil} = 1;
}
is( scalar keys %seen_wits, 13, "No extra witnesses were made" );
foreach my $k ( keys %seen_wits ) {
	ok( $seen_wits{$k}, "Witness $k still exists" );
}

# Check that the witnesses have the right texts
foreach my $wit ( $t->witnesses ) {
	my $origtext = join( ' ', @{$wit->text} );
	my $graphtext = $t->collation->path_text( $wit->sigil );
	is( $graphtext, $origtext, "Collation matches original for witness " . $wit->sigil );
}

# Check that the a.c. witnesses have the right text
map { $seen_wits{$_} = 0 } qw/ A B C D F G H K S /;
foreach my $k ( keys %seen_wits ) {
	my $wit = $t->witness( $k );
	if( $seen_wits{$k} ) {
		ok( $wit->is_layered, "Witness $k got marked as layered" );
		ok( $wit->has_layertext, "Witness $k has an a.c. version" );
		my $origtext = join( ' ', @{$wit->layertext} );
		my $acsig = $wit->sigil . $t->collation->ac_label;
		my $graphtext = $t->collation->path_text( $acsig );
		is( $graphtext, $origtext, "Collation matches original a.c. for witness $k" );
	} else {
		ok( !$wit->is_layered, "Witness $k not marked as layered" );
		ok( !$wit->has_layertext, "Witness $k has no a.c. version" );
	}
}	

=end testing

=cut

sub parse {
    my( $tradition, $opts ) = @_;
    my $c = $tradition->collation; # shorthand
    my $csv_options = { 'binary' => 1 };
    $csv_options->{'sep_char'} = $opts->{'sep_char'} || "\t";
    if( $csv_options->{'sep_char'} eq "\t" ) {
    	# If it is really tab separated, nothing is an escape char.
    	$csv_options->{'quote_char'} = undef;
    }
    my $csv = Text::CSV_XS->new( $csv_options );
    
    my $alignment_table;
    if( exists $opts->{'string' } ) {
        my @lines = split( "\n", $opts->{'string'} );
        foreach my $l ( @lines ) {
            my $status = $csv->parse( $l );
            if( $status ) {
                push( @$alignment_table, [ $csv->fields ] );
            } else {
                warn "Could not parse line $l: " . $csv->error_input;
            }
        }
    } elsif( exists $opts->{'file'} ) {
        open( my $fh, $opts->{'file'} ) 
            or warn "Could not open input file " . $opts->{'file'};
        binmode( $fh, ':utf8' );
        while( my $row = $csv->getline( $fh ) ) {
            push( @$alignment_table, $row );
        }
        close $fh;
    } else {
        warn "Could not find string or file option to parse";
        return;
    }

    # Set up the witnesses we find in the first line
    my @witnesses;
    my %ac_wits;  # Track layered witness -> main witness mapping
    foreach my $sigil ( @{$alignment_table->[0]} ) {
        my $wit = $tradition->add_witness( 'sigil' => $sigil );
        $wit->path( [ $c->start ] );
        push( @witnesses, $wit );
        my $aclabel = $c->ac_label;
        if( $sigil =~ /^(.*)\Q$aclabel\E$/ ) {
            $ac_wits{$sigil} = $1;
        }
    }
    
    # Save the original witness text sequences. Have to loop back through
    # the witness columns after we have identified all the a.c. witnesses.
    foreach my $idx ( 0 .. $#{$alignment_table->[0]} ) {
    	my @sequence = map { $_->[$idx] } @{$alignment_table};
    	my $sigil = shift @sequence;
    	my $is_layer = exists( $ac_wits{$sigil} );
    	my $wit = $tradition->witness( $is_layer ? $ac_wits{$sigil} : $sigil );	
    	# Now get rid of gaps and meta-readings like #LACUNA#
    	my @words = grep { $_ && $_ !~ /^\#.*\#$/ } @sequence;
    	$is_layer ? $wit->layertext( \@words ) : $wit->text( \@words );
    }    
    
    # Now for the next rows, make nodes as necessary, assign their ranks, and 
    # add them to the witness paths.
    foreach my $idx ( 1 .. $#{$alignment_table} ) {
        my $row = $alignment_table->[$idx];
        my $nodes = make_nodes( $c, $row, $idx );
        foreach my $w ( 0 .. $#{$row} ) {
            # push the appropriate node onto the appropriate witness path
            my $word = $row->[$w];
            if( $word ) {
                my $reading = $nodes->{$word};
                my $wit = $witnesses[$w];
                push( @{$wit->path}, $reading );
            } # else skip it for empty readings.
        }
    }
    
    # Collapse our lacunae into a single node and
    # push the end node onto all paths.
    $c->end->rank( scalar @$alignment_table );
    foreach my $wit ( @witnesses ) {
        my $p = $wit->path;
        my $last_rdg = shift @$p;
        my $new_p = [ $last_rdg ];
        foreach my $rdg ( @$p ) {
        	# Omit the reading if we are in a lacuna already.
        	next if $rdg->is_lacuna && $last_rdg->is_lacuna;
			# Save the reading otherwise.
			push( @$new_p, $rdg );
			$last_rdg = $rdg;
        }
        push( @$new_p, $c->end );
        $wit->path( $new_p );
    }
    
    # Fold any a.c. witnesses into their main witness objects, and
    # delete the independent a.c. versions.
    foreach my $a ( keys %ac_wits ) {
    	my $ac_wit = $tradition->witness( $a );
        my $main_wit = $tradition->witness( $ac_wits{$a} );
        next unless $main_wit;
        $main_wit->is_layered(1);
        $main_wit->uncorrected_path( $ac_wit->path );
        $tradition->del_witness( $ac_wit );
    }
    
    # Join up the paths.
    $c->make_witness_paths;
    # Delete our unused lacuna nodes.
	foreach my $rdg ( grep { $_->is_lacuna } $c->readings ) {
		$c->del_reading( $rdg ) unless $c->reading_witnesses( $rdg );
	}
	
	# Do a consistency check.
	foreach my $wit ( $tradition->witnesses ) {
		my $pathtext = $c->path_text( $wit->sigil );
		my $origtext = join( ' ', @{$wit->text} );
		warn "Text differs for witness " . $wit->sigil 
			unless $pathtext eq $origtext;
		if( $wit->is_layered ) {
			$pathtext = $c->path_text( $wit->sigil.$c->ac_label );
			$origtext = join( ' ', @{$wit->layertext} );
			warn "Ante-corr text differs for witness " . $wit->sigil
				unless $pathtext eq $origtext;
		} else {
			warn "Text " . $wit->sigil . " has a layered text but is not marked as layered"
				if $wit->has_layertext;
		}
	}
}

sub make_nodes {
    my( $collation, $row, $index ) = @_;
    my %unique;
    foreach my $w ( @$row ) {
        $unique{$w} = 1 if $w;
    }
    my $ctr = 1;
    foreach my $w ( keys %unique ) {
    	my $rargs = {
    		'id' => "$index,$ctr",
    		'rank' => $index,
    		'text' => $w,
    		};
    	$rargs->{'is_lacuna'} = 1 if $w eq '#LACUNA#';
        my $r = $collation->add_reading( $rargs );
        $unique{$w} = $r;
        $ctr++;
    }
    return \%unique;
}

1;

=head1 LICENSE

This package is free software and is provided "as is" without express
or implied warranty.  You can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 AUTHOR

Tara L Andrews E<lt>aurum@cpan.orgE<gt>
Commit	Line	Data
d9e873d0	1	package Text::Tradition::Parser::Tabular;
	2
	3	use strict;
	4	use warnings;
	5	use Text::CSV_XS;
	6
	7	=head1 NAME
	8
	9	Text::Tradition::Parser::Tabular
	10
3b853983	11	=head1 SYNOPSIS
	12
	13	use Text::Tradition;
	14
	15	my $t_from_file = Text::Tradition->new(
	16	'name' => 'my text',
	17	'input' => 'Tabular',
	18	'file' => '/path/to/collation.csv',
	19	'sep_char' => ','
	20	);
	21
	22	my $t_from_string = Text::Tradition->new(
	23	'name' => 'my text',
	24	'input' => 'Tabular',
	25	'string' => $tab_separated_collation,
	26	'sep_char' => "\t",
	27	);
	28
d9e873d0	29	=head1 DESCRIPTION
	30
	31	Parser module for Text::Tradition to read an alignment table format, such as CSV.
	32
	33	=head1 METHODS
	34
e867486f	35	=head2 B<parse>( $tradition, $option_hash )
3b853983	36
	37	Takes an initialized tradition and a set of options; creates the
	38	appropriate nodes and edges on the graph, as well as the appropriate
	39	witness objects. The $option_hash must contain either a 'file' or a
	40	'string' argument with the table to be parsed; it may also contain a
	41	'sep_char' argument to specify how the fields are separated.
	42
	43	The table should have witnesses arranged in columns, with the witness sigla
	44	in the first row. Empty cells are interpreted as omissions (and thus
	45	stemmatologically relevant.) Longer lacunae in the text, to be disregarded
	46	in cladistic analysis, may be represented by filling the appropriate cells
	47	with the tag '#LACUNA#'.
	48
	49	If a witness name ends in the collation's ac_label, it will be treated as
	50	an 'ante-correction' version of the 'main' witness whose sigil it shares.
	51
	52	=begin testing
	53
	54	use Text::Tradition;
	55	binmode STDOUT, ":utf8";
	56	binmode STDERR, ":utf8";
	57	eval { no warnings; binmode $DB::OUT, ":utf8"; };
	58
	59	my $csv = 't/data/florilegium.csv';
	60	my $t = Text::Tradition->new(
	61	'name' => 'inline',
	62	'input' => 'Tabular',
	63	'file' => $csv,
	64	'sep_char' => ',',
	65	);
d9e873d0	66
3b853983	67	is( ref( $t ), 'Text::Tradition', "Parsed florilegium CSV file" );
d9e873d0	68
3b853983	69	### TODO Check these figures
3b853983	70	if( $t ) {
0e47f4f6	71	is( scalar $t->collation->readings, 311, "Collation has all readings" );
0e47f4f6	72	is( scalar $t->collation->paths, 361, "Collation has all paths" );
3b853983	73	is( scalar $t->witnesses, 13, "Collation has all witnesses" );
	74	}
	75
b0b4421a	76	# Check that we have the right witnesses
	77	my %seen_wits;
	78	map { $seen_wits{$_} = 0 } qw/ A B C D E F G H K P Q S T /;
	79	foreach my $wit ( $t->witnesses ) {
	80	$seen_wits{$wit->sigil} = 1;
	81	}
	82	is( scalar keys %seen_wits, 13, "No extra witnesses were made" );
	83	foreach my $k ( keys %seen_wits ) {
	84	ok( $seen_wits{$k}, "Witness $k still exists" );
	85	}
	86
	87	# Check that the witnesses have the right texts
	88	foreach my $wit ( $t->witnesses ) {
	89	my $origtext = join( ' ', @{$wit->text} );
	90	my $graphtext = $t->collation->path_text( $wit->sigil );
	91	is( $graphtext, $origtext, "Collation matches original for witness " . $wit->sigil );
	92	}
	93
	94	# Check that the a.c. witnesses have the right text
	95	map { $seen_wits{$_} = 0 } qw/ A B C D F G H K S /;
	96	foreach my $k ( keys %seen_wits ) {
	97	my $wit = $t->witness( $k );
	98	if( $seen_wits{$k} ) {
	99	ok( $wit->is_layered, "Witness $k got marked as layered" );
	100	ok( $wit->has_layertext, "Witness $k has an a.c. version" );
	101	my $origtext = join( ' ', @{$wit->layertext} );
	102	my $acsig = $wit->sigil . $t->collation->ac_label;
861c3e27	103	my $graphtext = $t->collation->path_text( $acsig );
b0b4421a	104	is( $graphtext, $origtext, "Collation matches original a.c. for witness $k" );
	105	} else {
	106	ok( !$wit->is_layered, "Witness $k not marked as layered" );
	107	ok( !$wit->has_layertext, "Witness $k has no a.c. version" );
	108	}
	109	}
	110
3b853983	111	=end testing
d9e873d0	112
	113	=cut
	114
	115	sub parse {
dfc37e38	116	my( $tradition, $opts ) = @_;
d9e873d0	117	my $c = $tradition->collation; # shorthand
97a52a67	118	my $csv_options = { 'binary' => 1 };
	119	$csv_options->{'sep_char'} = $opts->{'sep_char'} \|\| "\t";
	120	if( $csv_options->{'sep_char'} eq "\t" ) {
	121	# If it is really tab separated, nothing is an escape char.
	122	$csv_options->{'quote_char'} = undef;
	123	}
	124	my $csv = Text::CSV_XS->new( $csv_options );
dfc37e38	125
d9e873d0	126	my $alignment_table;
dfc37e38	127	if( exists $opts->{'string' } ) {
	128	my @lines = split( "\n", $opts->{'string'} );
	129	foreach my $l ( @lines ) {
	130	my $status = $csv->parse( $l );
	131	if( $status ) {
	132	push( @$alignment_table, [ $csv->fields ] );
	133	} else {
	134	warn "Could not parse line $l: " . $csv->error_input;
	135	}
	136	}
	137	} elsif( exists $opts->{'file'} ) {
bb11025b	138	open( my $fh, $opts->{'file'} )
	139	or warn "Could not open input file " . $opts->{'file'};
	140	binmode( $fh, ':utf8' );
dfc37e38	141	while( my $row = $csv->getline( $fh ) ) {
dfc37e38	142	push( @$alignment_table, $row );
d9e873d0	143	}
dfc37e38	144	close $fh;
	145	} else {
	146	warn "Could not find string or file option to parse";
	147	return;
d9e873d0	148	}
dfc37e38	149
d9e873d0	150	# Set up the witnesses we find in the first line
d9e873d0	151	my @witnesses;
b0b4421a	152	my %ac_wits; # Track layered witness -> main witness mapping
d9e873d0	153	foreach my $sigil ( @{$alignment_table->[0]} ) {
	154	my $wit = $tradition->add_witness( 'sigil' => $sigil );
	155	$wit->path( [ $c->start ] );
	156	push( @witnesses, $wit );
3b853983	157	my $aclabel = $c->ac_label;
3b853983	158	if( $sigil =~ /^(.*)\Q$aclabel\E$/ ) {
b0b4421a	159	$ac_wits{$sigil} = $1;
3b853983	160	}
d9e873d0	161	}
d9e873d0	162
b0b4421a	163	# Save the original witness text sequences. Have to loop back through
	164	# the witness columns after we have identified all the a.c. witnesses.
	165	foreach my $idx ( 0 .. $#{$alignment_table->[0]} ) {
	166	my @sequence = map { $_->[$idx] } @{$alignment_table};
	167	my $sigil = shift @sequence;
	168	my $is_layer = exists( $ac_wits{$sigil} );
	169	my $wit = $tradition->witness( $is_layer ? $ac_wits{$sigil} : $sigil );
	170	# Now get rid of gaps and meta-readings like #LACUNA#
	171	my @words = grep { $_ && $_ !~ /^\#.*\#$/ } @sequence;
	172	$is_layer ? $wit->layertext( \@words ) : $wit->text( \@words );
	173	}
	174
d9e873d0	175	# Now for the next rows, make nodes as necessary, assign their ranks, and
d9e873d0	176	# add them to the witness paths.
d9e873d0	177	foreach my $idx ( 1 .. $#{$alignment_table} ) {
	178	my $row = $alignment_table->[$idx];
	179	my $nodes = make_nodes( $c, $row, $idx );
	180	foreach my $w ( 0 .. $#{$row} ) {
	181	# push the appropriate node onto the appropriate witness path
	182	my $word = $row->[$w];
	183	if( $word ) {
	184	my $reading = $nodes->{$word};
	185	my $wit = $witnesses[$w];
	186	push( @{$wit->path}, $reading );
	187	} # else skip it for empty readings.
	188	}
	189	}
	190
eca16057	191	# Collapse our lacunae into a single node and
eca16057	192	# push the end node onto all paths.
d9e873d0	193	$c->end->rank( scalar @$alignment_table );
d9e873d0	194	foreach my $wit ( @witnesses ) {
eca16057	195	my $p = $wit->path;
	196	my $last_rdg = shift @$p;
	197	my $new_p = [ $last_rdg ];
	198	foreach my $rdg ( @$p ) {
83d5ac3a	199	# Omit the reading if we are in a lacuna already.
	200	next if $rdg->is_lacuna && $last_rdg->is_lacuna;
	201	# Save the reading otherwise.
	202	push( @$new_p, $rdg );
	203	$last_rdg = $rdg;
eca16057	204	}
	205	push( @$new_p, $c->end );
	206	$wit->path( $new_p );
d9e873d0	207	}
d9e873d0	208
3b853983	209	# Fold any a.c. witnesses into their main witness objects, and
	210	# delete the independent a.c. versions.
	211	foreach my $a ( keys %ac_wits ) {
b0b4421a	212	my $ac_wit = $tradition->witness( $a );
b0b4421a	213	my $main_wit = $tradition->witness( $ac_wits{$a} );
3b853983	214	next unless $main_wit;
861c3e27	215	$main_wit->is_layered(1);
3b853983	216	$main_wit->uncorrected_path( $ac_wit->path );
	217	$tradition->del_witness( $ac_wit );
	218	}
83d5ac3a	219
d9e873d0	220	# Join up the paths.
d9e873d0	221	$c->make_witness_paths;
83d5ac3a	222	# Delete our unused lacuna nodes.
	223	foreach my $rdg ( grep { $_->is_lacuna } $c->readings ) {
	224	$c->del_reading( $rdg ) unless $c->reading_witnesses( $rdg );
	225	}
861c3e27	226
	227	# Do a consistency check.
	228	foreach my $wit ( $tradition->witnesses ) {
	229	my $pathtext = $c->path_text( $wit->sigil );
	230	my $origtext = join( ' ', @{$wit->text} );
	231	warn "Text differs for witness " . $wit->sigil
	232	unless $pathtext eq $origtext;
	233	if( $wit->is_layered ) {
	234	$pathtext = $c->path_text( $wit->sigil.$c->ac_label );
	235	$origtext = join( ' ', @{$wit->layertext} );
	236	warn "Ante-corr text differs for witness " . $wit->sigil
	237	unless $pathtext eq $origtext;
	238	} else {
	239	warn "Text " . $wit->sigil . " has a layered text but is not marked as layered"
	240	if $wit->has_layertext;
	241	}
	242	}
d9e873d0	243	}
	244
	245	sub make_nodes {
	246	my( $collation, $row, $index ) = @_;
	247	my %unique;
	248	foreach my $w ( @$row ) {
	249	$unique{$w} = 1 if $w;
	250	}
	251	my $ctr = 1;
	252	foreach my $w ( keys %unique ) {
a753cc84	253	my $rargs = {
a753cc84	254	'id' => "$index,$ctr",
	255	'rank' => $index,
	256	'text' => $w,
	257	};
9f213786	258	$rargs->{'is_lacuna'} = 1 if $w eq '#LACUNA#';
a753cc84	259	my $r = $collation->add_reading( $rargs );
d9e873d0	260	$unique{$w} = $r;
a753cc84	261	$ctr++;
d9e873d0	262	}
	263	return \%unique;
	264	}
	265
3b853983	266	1;
	267
	268	=head1 LICENSE
	269
	270	This package is free software and is provided "as is" without express
	271	or implied warranty. You can redistribute it and/or modify it under
	272	the same terms as Perl itself.
	273
	274	=head1 AUTHOR
	275
	276	Tara L Andrews E<lt>aurum@cpan.orgE<gt>