lib/Text/Tradition/Parser/CollateX.pm

   1 package Text::Tradition::Parser::CollateX;
   2
   3 use strict;
   4 use warnings;
   5 use Text::Tradition::Parser::GraphML qw/ graphml_parse /;
   6
   7 =head1 NAME
   8
   9 Text::Tradition::Parser::CollateX
  10
  11 =head1 SYNOPSIS
  12
  13   use Text::Tradition;
  14
  15   my $t_from_file = Text::Tradition->new(
  16     'name' => 'my text',
  17     'input' => 'CollateX',
  18     'file' => '/path/to/collation.xml'
  19     );
  20
  21   my $t_from_string = Text::Tradition->new(
  22     'name' => 'my text',
  23     'input' => 'CollateX',
  24     'string' => $collation_xml,
  25     );
  26
  27 =head1 DESCRIPTION
  28
  29 Parser module for Text::Tradition, given a GraphML file from the
  30 CollateX program that describes a collation graph.  For further
  31 information on the GraphML format for text collation, see
  32 http://gregor.middell.net/collatex/
  33
  34 =head1 METHODS
  35
  36 =head2 B<parse>
  37
  38 parse( $tradition, $init_options );
  39
  40 Takes an initialized Text::Tradition object and a set of options; creates
  41 the appropriate nodes and edges on the graph.  The options hash should
  42 include either a 'file' argument or a 'string' argument, depending on the
  43 source of the XML to be parsed.
  44
  45 =begin testing
  46
  47 use Text::Tradition;
  48 binmode STDOUT, ":utf8";
  49 binmode STDERR, ":utf8";
  50 eval { no warnings; binmode $DB::OUT, ":utf8"; };
  51
  52 my $cxfile = 't/data/Collatex-16.xml';
  53 my $t = Text::Tradition->new(
  54     'name'  => 'inline',
  55     'input' => 'CollateX',
  56     'file'  => $cxfile,
  57     );
  58
  59 is( ref( $t ), 'Text::Tradition', "Parsed our own GraphML" );
  60 if( $t ) {
  61     is( scalar $t->collation->readings, 26, "Collation has all readings" );
  62     is( scalar $t->collation->paths, 32, "Collation has all paths" );
  63     is( scalar $t->witnesses, 3, "Collation has all witnesses" );
  64
  65     # Check an 'identical' node
  66     my $transposed = $t->collation->reading( 'n15' );
  67     my @related = $transposed->related_readings;
  68     is( scalar @related, 1, "Reading links to transposed version" );
  69     is( $related[0]->id, 'n17', "Correct transposition link" );
  70 }
  71
  72 =end testing
  73
  74 =cut
  75
  76 my $IDKEY = 'number';
  77 my $CONTENTKEY = 'token';
  78 my $TRANSKEY = 'identical';
  79
  80 sub parse {
  81     my( $tradition, $opts ) = @_;
  82     my( $graph_data ) = graphml_parse( $opts );
  83     my $collation = $tradition->collation;
  84
  85         # First add the readings to the graph.
  86     my $extra_data = {}; # Keep track of info to be processed after all
  87                          # nodes have been created
  88     foreach my $n ( @{$graph_data->{'nodes'}} ) {
  89         unless( defined $n->{$IDKEY} && defined $n->{$CONTENTKEY} ) {
  90             warn "Did not find an ID or token for graph node, can't add it";
  91             next;
  92         }
  93         my %node_data = %$n;
  94         my $gnode_args = {
  95                 'id' => delete $node_data{$IDKEY},
  96                 'text' => delete $node_data{$CONTENTKEY},
  97         };
  98         my $gnode = $collation->add_reading( $gnode_args );
  99
 100         # Whatever is left is extra info to be processed later,
 101         # e.g. a transposition link.
 102         if( keys %node_data ) {
 103             $extra_data->{$gnode->id} = \%node_data;
 104         }
 105     }
 106
 107     # Now add the path edges.
 108     foreach my $e ( @{$graph_data->{'edges'}} ) {
 109         my %edge_data = %$e;
 110         my $from = delete $edge_data{'source'};
 111         my $to = delete $edge_data{'target'};
 112
 113         # In CollateX, we have a distinct witness data ID per witness,
 114         # so that we can have multiple witnesses per edge.  We want to
 115         # translate this to one witness per edge in our own
 116         # representation.
 117         foreach my $ekey ( keys %edge_data ) {
 118             my $wit = $edge_data{$ekey};
 119             # Create the witness object if it does not yet exist.
 120             unless( $tradition->witness( $wit ) ) {
 121                 $tradition->add_witness( 'sigil' => $wit );
 122             }
 123             $collation->add_path( $from->{$IDKEY}, $to->{$IDKEY}, $wit );
 124         }
 125     }
 126
 127     # Process the extra node data if it exists.
 128     foreach my $nodeid ( keys %$extra_data ) {
 129         my $ed = $extra_data->{$nodeid};
 130         if( exists $ed->{$TRANSKEY} ) {
 131             my $tn_reading = $collation->reading( $nodeid );
 132             my $main_reading = $collation->reading( $ed->{$TRANSKEY} );
 133             if( $collation->linear ) {
 134                 $collation->add_relationship( $tn_reading, $main_reading,
 135                         { type => 'transposition' } );
 136             } else {
 137                 $collation->merge_readings( $main_reading, $tn_reading );
 138             }
 139         } # else we don't have any other tags to process yet.
 140     }
 141
 142     # Find the beginning and end nodes of the graph.  The beginning node
 143     # has no incoming edges; the end node has no outgoing edges.
 144     my( $begin_node, $end_node );
 145     my @starts = $collation->sequence->source_vertices();
 146     my @ends = $collation->sequence->sink_vertices();
 147     if( @starts != 1 ) {
 148         warn "Found more or less than one start vertex: @starts";
 149     } else {
 150         $collation->merge_readings( $collation->start, @starts );
 151     }
 152     if( @ends != 1 )  {
 153         warn "Found more or less than one end vertex: @ends";
 154     } else {
 155         $collation->merge_readings( $collation->end, @ends );
 156     }
 157
 158     # Rank the readings.
 159     $collation->calculate_common_readings(); # will implicitly rank
 160
 161     # Save the text for each witness so that we can ensure consistency
 162     # later on
 163         $tradition->collation->text_from_paths();
 164 }
 165
 166 =head1 BUGS / TODO
 167
 168 =over
 169
 170 =item * Make this into a stream parser with GraphML
 171
 172 =item * Use CollateX-calculated ranks instead of recalculating our own
 173
 174 =back
 175
 176 =head1 LICENSE
 177
 178 This package is free software and is provided "as is" without express
 179 or implied warranty.  You can redistribute it and/or modify it under
 180 the same terms as Perl itself.
 181
 182 =head1 AUTHOR
 183
 184 Tara L Andrews, aurum@cpan.org
 185
 186 =cut
 187
 188 1;