lib/Text/Tradition/Parser/Self.pm

   1 package Text::Tradition::Parser::Self;
   2
   3 use strict;
   4 use warnings;
   5 use Text::Tradition::Parser::GraphML qw/ graphml_parse populate_witness_path /;
   6
   7 =head1 NAME
   8
   9 Text::Tradition::Parser::GraphML
  10
  11 =head1 SYNOPSIS
  12
  13   use Text::Tradition;
  14
  15   my $t_from_file = Text::Tradition->new(
  16     'name' => 'my text',
  17     'input' => 'Self',
  18     'file' => '/path/to/tradition.xml'
  19     );
  20
  21   my $t_from_string = Text::Tradition->new(
  22     'name' => 'my text',
  23     'input' => 'Self',
  24     'string' => $tradition_xml,
  25     );
  26
  27 =head1 DESCRIPTION
  28
  29 Parser module for Text::Tradition to read in its own GraphML output format.
  30 GraphML is a relatively simple graph description language; a 'graph' element
  31 can have 'node' and 'edge' elements, and each of these can have simple 'data'
  32 elements for attributes to be saved.
  33
  34 The graph itself has attributes as in the Collation object:
  35
  36 =over
  37
  38 =item * linear
  39
  40 =item * ac_label
  41
  42 =item * baselabel
  43
  44 =item * wit_list_separator
  45
  46 =back
  47
  48 The node objects have the following attributes:
  49
  50 =over
  51
  52 =item * name
  53
  54 =item * reading
  55
  56 =item * identical
  57
  58 =item * rank
  59
  60 =item * class
  61
  62 =back
  63
  64 The edge objects have the following attributes:
  65
  66 =over
  67
  68 =item * class
  69
  70 =item * witness (for 'path' class edges)
  71
  72 =item * extra   (for 'path' class edges)
  73
  74 =item * relationship    (for 'relationship' class edges)
  75
  76 =item * equal_rank      (for 'relationship' class edges)
  77
  78 =item * non_correctable (for 'relationship' class edges)
  79
  80 =item * non_independent (for 'relationship' class edges)
  81
  82 =back
  83
  84 =head1 METHODS
  85
  86 =head2 B<parse>
  87
  88 parse( $graph, $opts );
  89
  90 Takes an initialized Text::Tradition object and a set of options; creates
  91 the appropriate nodes and edges on the graph.  The options hash should
  92 include either a 'file' argument or a 'string' argument, depending on the
  93 source of the XML to be parsed.
  94
  95 =begin testing
  96
  97 use Text::Tradition;
  98 binmode STDOUT, ":utf8";
  99 binmode STDERR, ":utf8";
 100 eval { no warnings; binmode $DB::OUT, ":utf8"; };
 101
 102 my $tradition = 't/data/florilegium_graphml.xml';
 103 my $t = Text::Tradition->new(
 104     'name'  => 'inline',
 105     'input' => 'Self',
 106     'file'  => $tradition,
 107     );
 108
 109 is( ref( $t ), 'Text::Tradition', "Parsed our own GraphML" );
 110 if( $t ) {
 111     is( scalar $t->collation->readings, 319, "Collation has all readings" );
 112     is( scalar $t->collation->paths, 2854, "Collation has all paths" );
 113     is( scalar $t->witnesses, 13, "Collation has all witnesses" );
 114 }
 115
 116 =end testing
 117
 118 =cut
 119
 120 my( $IDKEY, $TOKENKEY, $TRANSPOS_KEY, $RANK_KEY, $CLASS_KEY,
 121         $SOURCE_KEY, $TARGET_KEY, $WITNESS_KEY, $EXTRA_KEY, $RELATIONSHIP_KEY )
 122     = qw/ name reading identical rank class
 123           source target witness extra relationship/;
 124
 125 sub parse {
 126     my( $tradition, $opts ) = @_;
 127     my $graph_data = graphml_parse( $opts );
 128
 129     my $collation = $tradition->collation;
 130     my %witnesses;
 131
 132     # Set up the graph-global attributes.  They will appear in the
 133     # hash under their accessor names.
 134     print STDERR "Setting graph globals\n";
 135     $tradition->name( $graph_data->{'name'} );
 136     foreach my $gkey ( keys %{$graph_data->{'attr'}} ) {
 137                 my $val = $graph_data->{'attr'}->{$gkey};
 138                 $collation->$gkey( $val );
 139         }
 140
 141     # Add the nodes to the graph.
 142
 143     my $extra_data = {}; # Keep track of data that needs to be processed
 144                          # after the nodes & edges are created.
 145     print STDERR "Adding graph nodes\n";
 146     foreach my $n ( @{$graph_data->{'nodes'}} ) {
 147         # First extract the data that we can use without reference to
 148         # anything else.
 149         my %node_data = %$n; # Need $n itself untouched for edge processing
 150         my $nodeid = delete $node_data{$IDKEY};
 151         my $reading = delete $node_data{$TOKENKEY};
 152         my $class = delete $node_data{$CLASS_KEY} || '';
 153         my $rank = delete $node_data{$RANK_KEY};
 154
 155         # Create the node.  Current valid classes are common and meta.
 156         # Everything else is a normal reading.
 157         my $gnode = $collation->add_reading( $nodeid );
 158         $gnode->text( $reading );
 159         $gnode->make_common if $class eq 'common';
 160         $gnode->is_meta( 1 ) if $class eq 'meta';
 161         # This is a horrible hack.
 162         $gnode->is_lacuna( $reading =~ /^\#LACUNA/ );
 163         $gnode->rank( $rank ) if defined $rank;
 164
 165         # Now save the data that we need for post-processing,
 166         # if it exists.
 167         if ( keys %node_data ) {
 168             $extra_data->{$nodeid} = \%node_data
 169         }
 170     }
 171
 172     # Now add the edges.
 173     print STDERR "Adding graph edges\n";
 174     my $has_ante_corr = {};
 175     foreach my $e ( @{$graph_data->{'edges'}} ) {
 176         my $from = $e->{$SOURCE_KEY};
 177         my $to = $e->{$TARGET_KEY};
 178         my $class = $e->{$CLASS_KEY};
 179
 180         # We may have more information depending on the class.
 181         if( $class eq 'path' ) {
 182                 # We need the witness, and whether it is an 'extra' reading path.
 183                 my $wit = $e->{$WITNESS_KEY};
 184                 warn "No witness label on path edge!" unless $wit;
 185                 my $extra = $e->{$EXTRA_KEY};
 186                 my $label = $wit . ( $extra ? $collation->ac_label : '' );
 187                 $collation->add_path( $from->{$IDKEY}, $to->{$IDKEY}, $label );
 188                 # Add the witness if we don't have it already.
 189                         unless( $witnesses{$wit} ) {
 190                                 $tradition->add_witness( sigil => $wit );
 191                                 $witnesses{$wit} = 1;
 192                         }
 193                         $has_ante_corr->{$wit} = 1 if $extra;
 194         } elsif( $class eq 'relationship' ) {
 195                 # We need the metadata about the relationship.
 196                 my $opts = { 'type' => $e->{$RELATIONSHIP_KEY} };
 197                 $opts->{'equal_rank'} = $e->{'equal_rank'}
 198                         if exists $e->{'equal_rank'};
 199                 $opts->{'non_correctable'} = $e->{'non_correctable'}
 200                         if exists $e->{'non_correctable'};
 201                 $opts->{'non_independent'} = $e->{'non_independent'}
 202                         if exists $e->{'non_independent'};
 203                 warn "No relationship type for relationship edge!" unless $opts->{'type'};
 204                 my( $ok, @result ) = $collation->add_relationship( $from->{$IDKEY}, $to->{$IDKEY}, $opts );
 205                 unless( $ok ) {
 206                         warn "Did not add relationship: @result";
 207                 }
 208         }
 209     }
 210
 211     ## Deal with node information (transposition, relationships, etc.) that
 212     ## needs to be processed after all the nodes are created.
 213     print STDERR "Adding second-pass node data\n";
 214     foreach my $nkey ( keys %$extra_data ) {
 215         foreach my $edkey ( keys %{$extra_data->{$nkey}} ) {
 216             my $this_reading = $collation->reading( $nkey );
 217             if( $edkey eq $TRANSPOS_KEY ) {
 218                 my $other_reading = $collation->reading( $extra_data->{$nkey}->{$edkey} );
 219                 $this_reading->set_identical( $other_reading );
 220             } else {
 221                 warn "Unfamiliar reading node data $edkey for $nkey";
 222             }
 223         }
 224     }
 225
 226     # Set the $witness->path arrays for each wit.
 227     populate_witness_path( $tradition, $has_ante_corr );
 228 }
 229
 230 1;
 231
 232 =head1 BUGS / TODO
 233
 234 =over
 235
 236 =item * Make this into a stream parser with GraphML
 237
 238 =item * Simply field -> attribute correspondence for nodes and edges
 239
 240 =item * Share key name constants with Collation.pm
 241
 242 =back
 243
 244 =head1 LICENSE
 245
 246 This package is free software and is provided "as is" without express
 247 or implied warranty.  You can redistribute it and/or modify it under
 248 the same terms as Perl itself.
 249
 250 =head1 AUTHOR
 251
 252 Tara L Andrews E<lt>aurum@cpan.orgE<gt>