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                 'collation' => $collation,
  96                 'id' => delete $node_data{$IDKEY},
  97                 'text' => delete $node_data{$CONTENTKEY},
  98         };
  99         my $gnode = $collation->add_reading( $gnode_args );
 100
 101         # Whatever is left is extra info to be processed later,
 102         # e.g. a transposition link.
 103         if( keys %node_data ) {
 104             $extra_data->{$gnode->id} = \%node_data;
 105         }
 106     }
 107
 108     # Now add the path edges.
 109     foreach my $e ( @{$graph_data->{'edges'}} ) {
 110         my %edge_data = %$e;
 111         my $from = delete $edge_data{'source'};
 112         my $to = delete $edge_data{'target'};
 113
 114         # In CollateX, we have a distinct witness data ID per witness,
 115         # so that we can have multiple witnesses per edge.  We want to
 116         # translate this to one witness per edge in our own
 117         # representation.
 118         foreach my $ekey ( keys %edge_data ) {
 119             my $wit = $edge_data{$ekey};
 120             # Create the witness object if it does not yet exist.
 121             unless( $tradition->witness( $wit ) ) {
 122                 $tradition->add_witness( 'sigil' => $wit );
 123             }
 124             $collation->add_path( $from->{$IDKEY}, $to->{$IDKEY}, $wit );
 125         }
 126     }
 127
 128     # Process the extra node data if it exists.
 129     foreach my $nodeid ( keys %$extra_data ) {
 130         my $ed = $extra_data->{$nodeid};
 131         if( exists $ed->{$TRANSKEY} ) {
 132             my $tn_reading = $collation->reading( $nodeid );
 133             my $main_reading = $collation->reading( $ed->{$TRANSKEY} );
 134             if( $collation->linear ) {
 135                 $collation->add_relationship( $tn_reading, $main_reading,
 136                         { type => 'transposition' } );
 137             } else {
 138                 $collation->merge_readings( $main_reading, $tn_reading );
 139             }
 140         } # else we don't have any other tags to process yet.
 141     }
 142
 143     # Find the beginning and end nodes of the graph.  The beginning node
 144     # has no incoming edges; the end node has no outgoing edges.
 145     my( $begin_node, $end_node );
 146     my @starts = $collation->sequence->source_vertices();
 147     my @ends = $collation->sequence->sink_vertices();
 148     if( @starts != 1 ) {
 149         warn "Found more or less than one start vertex: @starts";
 150     } else {
 151         $collation->merge_readings( $collation->start, @starts );
 152     }
 153     if( @ends != 1 )  {
 154         warn "Found more or less than one end vertex: @ends";
 155     } else {
 156         $collation->merge_readings( $collation->end, @ends );
 157     }
 158
 159     # Rank the readings.
 160     $collation->calculate_ranks() if $collation->linear;
 161 }
 162
 163 =head1 BUGS / TODO
 164
 165 =over
 166
 167 =item * Make this into a stream parser with GraphML
 168
 169 =item * Use CollateX-calculated ranks instead of recalculating our own
 170
 171 =back
 172
 173 =head1 LICENSE
 174
 175 This package is free software and is provided "as is" without express
 176 or implied warranty.  You can redistribute it and/or modify it under
 177 the same terms as Perl itself.
 178
 179 =head1 AUTHOR
 180
 181 Tara L Andrews, aurum@cpan.org
 182
 183 =cut
 184
 185 1;