X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FParser%2FTabular.pm;h=0048f87d77426b5e5f2489e54626f9d0e3b47497;hb=10e4b1acc8fc6607456481c568da930983efac33;hp=16e2863608963edae5d5c5742096acc8a32162d1;hpb=eca160573f4f28f53faa7dd97ee5cb6740a4b517;p=scpubgit%2Fstemmatology.git diff --git a/lib/Text/Tradition/Parser/Tabular.pm b/lib/Text/Tradition/Parser/Tabular.pm index 16e2863..0048f87 100644 --- a/lib/Text/Tradition/Parser/Tabular.pm +++ b/lib/Text/Tradition/Parser/Tabular.pm @@ -2,63 +2,189 @@ package Text::Tradition::Parser::Tabular; use strict; use warnings; -use Text::CSV_XS; +use Text::CSV; =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 -=over +=head2 B( $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" ); -=item B +### 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" ); + } +} -parse( $graph, $graphml_string ); +# Check that we only have collation relationships where we need them +is( scalar $t->collation->relationships, 3, "Redundant collations were removed" ); -Takes an initialized Text::Tradition::Graph object and a string -containing the GraphML; creates the appropriate nodes and edges on the -graph. +=end testing =cut sub parse { - my( $tradition, $tab_str ) = @_; - # TODO Allow setting of sep_char + my( $tradition, $opts ) = @_; my $c = $tradition->collation; # shorthand - my $csv = Text::CSV_XS->new( { binary => 1, # binary for UTF-8 - sep_char => "\t" } ); - my @lines = split( "\n", $tab_str ); - # Conveniently, we are basically receiving exactly the sort of alignment table - # we might want to produce later. May as well save it. + 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; + $csv_options->{'escape_char'} = undef; + } + my $csv = Text::CSV->new( $csv_options ); + my $alignment_table; - 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; + 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 + my $aclabel = $c->ac_label; foreach my $sigil ( @{$alignment_table->[0]} ) { - my $wit = $tradition->add_witness( 'sigil' => $sigil ); + if( $sigil =~ /^(.*)\Q$aclabel\E$/ ) { + # Sanitize the sigil name to an XML name + $sigil = $1 . '_layered'; + $ac_wits{$sigil} = $1; + } + my $wit = $tradition->add_witness( + 'sigil' => $sigil, 'sourcetype' => 'collation' ); $wit->path( [ $c->start ] ); push( @witnesses, $wit ); + my $aclabel = $c->ac_label; } + # 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. - $DB::single = 1; foreach my $idx ( 1 .. $#{$alignment_table} ) { my $row = $alignment_table->[$idx]; - my $nodes = make_nodes( $c, $row, $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]; @@ -70,7 +196,6 @@ sub parse { } } - # Collapse our lacunae into a single node and # push the end node onto all paths. $c->end->rank( scalar @$alignment_table ); @@ -79,49 +204,111 @@ sub parse { my $last_rdg = shift @$p; my $new_p = [ $last_rdg ]; foreach my $rdg ( @$p ) { - if( $rdg->text eq '#LACUNA#' ) { - # If we are in a lacuna already, drop this node. - # Otherwise make a lacuna node and drop this node. - unless( $last_rdg->is_lacuna ) { - my $l = $c->add_lacuna( $rdg->name ); - $l->rank( $rdg->rank ); - push( @$new_p, $l ); - $last_rdg = $l; - } - $c->del_reading( $rdg ); - } else { - # No lacuna, save the reading. - push( @$new_p, $rdg ); - } + # 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; - - # Save the alignment table that was so handily provided to us. - # TODO if we support other delimiters, we will have to re-export this - # rather than saving the original string. - $c->_save_csv( $tab_str ); + # 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; + } + } + + # Note that our ranks and common readings are set. + $c->_graphcalc_done(1); + # Remove redundant collation relationships. + $c->relations->filter_collations(); } -sub make_nodes { +sub _make_nodes { my( $collation, $row, $index ) = @_; my %unique; + my $commonctr = 0; # Holds the number of unique readings + gaps, ex. lacunae. foreach my $w ( @$row ) { $unique{$w} = 1 if $w; + $commonctr +=1 unless ( $w && $w eq '#LACUNA#' ); } my $ctr = 1; foreach my $w ( keys %unique ) { - my $r = $collation->add_reading( "$index,$ctr" ); - $ctr++; - $r->rank( $index ); - $r->text( $w ); + my $rargs = { + 'id' => "r$index.$ctr", + 'rank' => $index, + 'text' => $w, + }; + if( $w eq '#LACUNA#' ) { + $rargs->{'is_lacuna'} = 1; + } elsif( $commonctr == 1 ) { + $rargs->{'is_common'} = 1; + } + my $r = $collation->add_reading( $rargs ); $unique{$w} = $r; + $ctr++; + } + # Collate this sequence of readings via a single 'collation' relationship. + my @rankrdgs = values %unique; + my $collation_rel; + while( @rankrdgs ) { + my $r = shift @rankrdgs; + next if $r->is_meta; + foreach my $nr ( @rankrdgs ) { + next if $nr->is_meta; + if( $collation_rel ) { + $collation->add_relationship( $r, $nr, $collation_rel ); + } else { + $collation->add_relationship( $r, $nr, + { 'type' => 'collated', + 'annotation' => "Parsed together for rank $index" } ); + $collation_rel = $collation->get_relationship( $r, $nr ); + } + } } + return \%unique; } -1; \ No newline at end of file +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 Eaurum@cpan.orgE