lib/Text/Tradition/Parser/Tabular.pm

   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
  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
  29 =head1 DESCRIPTION
  30
  31 Parser module for Text::Tradition to read an alignment table format, such as CSV.
  32
  33 =head1 METHODS
  34
  35 =head2 B<parse>( $tradition, $option_hash )
  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     );
  66
  67 is( ref( $t ), 'Text::Tradition', "Parsed florilegium CSV file" );
  68
  69 ### TODO Check these figures
  70 if( $t ) {
  71     is( scalar $t->collation->readings, 312, "Collation has all readings" );
  72     is( scalar $t->collation->paths, 363, "Collation has all paths" );
  73     is( scalar $t->witnesses, 13, "Collation has all witnesses" );
  74 }
  75
  76 =end testing
  77
  78 =cut
  79
  80 sub parse {
  81     my( $tradition, $opts ) = @_;
  82     my $c = $tradition->collation; # shorthand
  83     my $csv = Text::CSV_XS->new( {
  84         binary => 1, # binary for UTF-8
  85         sep_char => exists $opts->{'sep_char'} ? $opts->{'sep_char'} : "\t" }
  86         );
  87
  88     my $alignment_table;
  89     if( exists $opts->{'string' } ) {
  90         my @lines = split( "\n", $opts->{'string'} );
  91         foreach my $l ( @lines ) {
  92             my $status = $csv->parse( $l );
  93             if( $status ) {
  94                 push( @$alignment_table, [ $csv->fields ] );
  95             } else {
  96                 warn "Could not parse line $l: " . $csv->error_input;
  97             }
  98         }
  99     } elsif( exists $opts->{'file'} ) {
 100         open( my $fh, $opts->{'file'} )
 101             or warn "Could not open input file " . $opts->{'file'};
 102         binmode( $fh, ':utf8' );
 103         while( my $row = $csv->getline( $fh ) ) {
 104             push( @$alignment_table, $row );
 105         }
 106         close $fh;
 107     } else {
 108         warn "Could not find string or file option to parse";
 109         return;
 110     }
 111
 112     # Set up the witnesses we find in the first line
 113     my @witnesses;
 114     my %ac_wits;  # Track these for later removal
 115     foreach my $sigil ( @{$alignment_table->[0]} ) {
 116         my $wit = $tradition->add_witness( 'sigil' => $sigil );
 117         $wit->path( [ $c->start ] );
 118         push( @witnesses, $wit );
 119         my $aclabel = $c->ac_label;
 120         if( $sigil =~ /^(.*)\Q$aclabel\E$/ ) {
 121             $ac_wits{$1} = $wit;
 122         }
 123     }
 124
 125     # Now for the next rows, make nodes as necessary, assign their ranks, and
 126     # add them to the witness paths.
 127     foreach my $idx ( 1 .. $#{$alignment_table} ) {
 128         my $row = $alignment_table->[$idx];
 129         my $nodes = make_nodes( $c, $row, $idx );
 130         foreach my $w ( 0 .. $#{$row} ) {
 131             # push the appropriate node onto the appropriate witness path
 132             my $word = $row->[$w];
 133             if( $word ) {
 134                 my $reading = $nodes->{$word};
 135                 my $wit = $witnesses[$w];
 136                 push( @{$wit->path}, $reading );
 137             } # else skip it for empty readings.
 138         }
 139     }
 140
 141     # Collapse our lacunae into a single node and
 142     # push the end node onto all paths.
 143     $c->end->rank( scalar @$alignment_table );
 144     foreach my $wit ( @witnesses ) {
 145         my $p = $wit->path;
 146         my $last_rdg = shift @$p;
 147         my $new_p = [ $last_rdg ];
 148         foreach my $rdg ( @$p ) {
 149                 $DB::single = 1 if $rdg->id eq '228,1';
 150             if( $rdg->text eq '#LACUNA#' ) {
 151                 # If we are in a lacuna already, drop this node.
 152                 # Otherwise make a lacuna node and drop this node.
 153                 unless( $last_rdg->is_lacuna ) {
 154                         my $l_id = 'l' . $rdg->id;
 155                         my $l;
 156                         if( $c->has_reading( $l_id ) ) {
 157                                 $l = $c->reading( $l_id );
 158                         } else {
 159                         $l = $c->add_reading( {
 160                                                         'collation' => $c,
 161                                                         'id' => $l_id,
 162                                                         'is_lacuna' => 1,
 163                                                         } );
 164                                         }
 165                     push( @$new_p, $l );
 166                     $last_rdg = $l;
 167                 }
 168                 $c->del_reading( $rdg );
 169             } else {
 170                 # No lacuna, save the reading.
 171                 push( @$new_p, $rdg );
 172             }
 173         }
 174         push( @$new_p, $c->end );
 175         $wit->path( $new_p );
 176     }
 177
 178     # Fold any a.c. witnesses into their main witness objects, and
 179     # delete the independent a.c. versions.
 180     foreach my $a ( keys %ac_wits ) {
 181         my $main_wit = $tradition->witness( $a );
 182         next unless $main_wit;
 183         my $ac_wit = $ac_wits{$a};
 184         $main_wit->uncorrected_path( $ac_wit->path );
 185         $tradition->del_witness( $ac_wit );
 186     }
 187
 188     # Join up the paths.
 189     $c->make_witness_paths;
 190 }
 191
 192 sub make_nodes {
 193     my( $collation, $row, $index ) = @_;
 194     my %unique;
 195     foreach my $w ( @$row ) {
 196         $unique{$w} = 1 if $w;
 197     }
 198     my $ctr = 1;
 199     foreach my $w ( keys %unique ) {
 200         my $rargs = {
 201                 'collation' => $collation,
 202                 'id' => "$index,$ctr",
 203                 'rank' => $index,
 204                 'text' => $w,
 205                 };
 206         my $r = $collation->add_reading( $rargs );
 207         $unique{$w} = $r;
 208         $ctr++;
 209     }
 210     return \%unique;
 211 }
 212
 213 1;
 214
 215 =head1 LICENSE
 216
 217 This package is free software and is provided "as is" without express
 218 or implied warranty.  You can redistribute it and/or modify it under
 219 the same terms as Perl itself.
 220
 221 =head1 AUTHOR
 222
 223 Tara L Andrews E<lt>aurum@cpan.orgE<gt>