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 DESCRIPTION
  12
  13 Parser module for Text::Tradition to read an alignment table format, such as CSV.
  14
  15 =head1 METHODS
  16
  17 =over
  18
  19 =item B<parse>
  20
  21 parse( $graph, $graphml_string );
  22
  23 Takes an initialized Text::Tradition::Graph object and a string
  24 containing the GraphML; creates the appropriate nodes and edges on the
  25 graph.
  26
  27 =cut
  28
  29 sub parse {
  30     my( $tradition, $tab_str ) = @_;
  31     # TODO Allow setting of sep_char
  32     my $c = $tradition->collation; # shorthand
  33     my $csv = Text::CSV_XS->new( { binary => 1, # binary for UTF-8
  34         sep_char => "\t" } );
  35     my @lines = split( "\n", $tab_str );
  36     # Conveniently, we are basically receiving exactly the sort of alignment table
  37     # we might want to produce later.  May as well save it.
  38     my $alignment_table;
  39     foreach my $l ( @lines ) {
  40         my $status = $csv->parse( $l );
  41         if( $status ) {
  42             push( @$alignment_table, [ $csv->fields ] );
  43         } else {
  44             warn "Could not parse line $l: " . $csv->error_input;
  45         }
  46     }
  47
  48     # Set up the witnesses we find in the first line
  49     my @witnesses;
  50     foreach my $sigil ( @{$alignment_table->[0]} ) {
  51         my $wit = $tradition->add_witness( 'sigil' => $sigil );
  52         $wit->path( [ $c->start ] );
  53         push( @witnesses, $wit );
  54     }
  55
  56     # Now for the next rows, make nodes as necessary, assign their ranks, and
  57     # add them to the witness paths.
  58     $DB::single = 1;
  59     foreach my $idx ( 1 .. $#{$alignment_table} ) {
  60         my $row = $alignment_table->[$idx];
  61         my $nodes = make_nodes( $c, $row, $idx );
  62         foreach my $w ( 0 .. $#{$row} ) {
  63             # push the appropriate node onto the appropriate witness path
  64             my $word = $row->[$w];
  65             if( $word ) {
  66                 my $reading = $nodes->{$word};
  67                 my $wit = $witnesses[$w];
  68                 push( @{$wit->path}, $reading );
  69             } # else skip it for empty readings.
  70         }
  71     }
  72
  73
  74     # Collapse our lacunae into a single node and
  75     # push the end node onto all paths.
  76     $c->end->rank( scalar @$alignment_table );
  77     foreach my $wit ( @witnesses ) {
  78         my $p = $wit->path;
  79         my $last_rdg = shift @$p;
  80         my $new_p = [ $last_rdg ];
  81         foreach my $rdg ( @$p ) {
  82             if( $rdg->text eq '#LACUNA#' ) {
  83                 # If we are in a lacuna already, drop this node.
  84                 # Otherwise make a lacuna node and drop this node.
  85                 unless( $last_rdg->is_lacuna ) {
  86                     my $l = $c->add_lacuna( $rdg->name );
  87                     $l->rank( $rdg->rank );
  88                     push( @$new_p, $l );
  89                     $last_rdg = $l;
  90                 }
  91                 $c->del_reading( $rdg );
  92             } else {
  93                 # No lacuna, save the reading.
  94                 push( @$new_p, $rdg );
  95             }
  96         }
  97         push( @$new_p, $c->end );
  98         $wit->path( $new_p );
  99     }
 100
 101     # Join up the paths.
 102     $c->make_witness_paths;
 103
 104     # Save the alignment table that was so handily provided to us.
 105     # TODO if we support other delimiters, we will have to re-export this
 106     # rather than saving the original string.
 107     $c->_save_csv( $tab_str );
 108 }
 109
 110 sub make_nodes {
 111     my( $collation, $row, $index ) = @_;
 112     my %unique;
 113     foreach my $w ( @$row ) {
 114         $unique{$w} = 1 if $w;
 115     }
 116     my $ctr = 1;
 117     foreach my $w ( keys %unique ) {
 118         my $r = $collation->add_reading( "$index,$ctr" );
 119         $ctr++;
 120         $r->rank( $index );
 121         $r->text( $w );
 122         $unique{$w} = $r;
 123     }
 124     return \%unique;
 125 }
 126
 127 1;