lib/Text/Tradition/Graph.pm

   1 package Text::Tradition::Graph;
   2
   3 use strict;
   4 use warnings;
   5 use Graph::Easy;
   6 use IPC::Run qw( run binary );
   7 use Module::Load;
   8 use Text::Tradition::Graph::Position;
   9
  10 =head1 NAME
  11
  12 Text::Tradition::Graph
  13
  14 =head1 SYNOPSIS
  15
  16  use Text::Tradition::Graph;
  17
  18  my $text = Text::Tradition::Graph->new( 'GraphML' => '/my/graphml/file.xml' );
  19  my $text = Text::Tradition::Graph->new( 'TEI' => '/my/tei/file.xml' );
  20  my $text = Text::Tradition::Graph->new( 'CSV' => '/my/csv/file.csv',
  21                                          'base' => '/my/basefile.txt' );
  22  my $text = Text::Tradition::Graph->new( 'CTE' => '/my/cte/file.txt',
  23                                          'base' => '/my/basefile.txt' );
  24
  25  my $svg_string = $text->as_svg();
  26
  27  my $lemma_nodes = $text->active_nodes();
  28  $text->toggle_node( 'some_word' );
  29
  30 =head1 DESCRIPTION
  31
  32 A text tradition is the representation of our knowledge of a text that
  33 has been passed down via manuscript copies from a time before printing
  34 presses.  Each text has a number of witnesses, that is, manuscripts
  35 that bear a version of the text.  The tradition is the aggregation of
  36 these witnesses, which is to say, the collation of the text.
  37
  38 This module takes a text collation and represents it as a horizontal
  39 directed graph, suitable for SVG rendering and for analysis of various
  40 forms.  Since this module was written by a medievalist, it also
  41 provides a facility for making a critical text reconstruction by
  42 choosing certain variants to be 'lemma' text - that is, text which
  43 should be considered the 'standard' reading.
  44
  45 Although the graph is a very good way to render text collation, and is
  46 visually very easy for a human to interpret, it doesn't have any
  47 inherent information about which nodes 'go together' - that is, which
  48 text readings appear in the same place as other readings.  This module
  49 therefore calculates 'positions' on the graph, thus holding some
  50 information about which readings can and can't be substituted for
  51 others.
  52
  53 =head1 METHODS
  54
  55 =over 4
  56
  57 =item B<new>
  58
  59 Constructor.  Takes a source collation file from which to construct
  60 the initial graph.  This file can be TEI (parallel segmentation) XML,
  61 CSV in a format yet to be documented, GraphML as documented by the
  62 CollateX tool (L<http://gregor.middell.net/collatex/>), or a Classical
  63 Text Editor apparatus.  For CSV and Classical Text Editor files, the
  64 user must also supply a base text to which the line numbering in the
  65 collation file refers.
  66
  67 20/04/2011 Currently only CSV and GraphML are really supported.
  68
  69 =cut
  70
  71 sub new {
  72     my $proto = shift;
  73     my $class = ref( $proto ) || $proto;
  74     my %opts = ( 'on_color' => 'yellow',
  75                  'off_color' => 'white',
  76                  @_ );
  77     my $self = {};
  78
  79     # opts can be: GraphML, base+CSV, base+CTE, TEI.  We need
  80     # something to parse.
  81     my @formats = grep { /^(GraphML|CSV|CTE|TEI)$/ } keys( %opts );
  82     my $format = shift( @formats );
  83     unless( $format ) {
  84         warn "No data given to create a graph; will initialize an empty one";
  85     }
  86     if( $format =~ /^(CSV|CTE)$/ && !exists $opts{'base'} ) {
  87         warn "Cannot make a graph from $format without a base text";
  88         return;
  89     }
  90
  91     # Make a graph object.
  92     my $collation_graph = Graph::Easy->new();
  93     $collation_graph->set_attribute( 'node', 'shape', 'ellipse' );
  94     # Starting point for all texts
  95     my $last_node = $collation_graph->add_node( '#START#' );
  96
  97     $self->{'graph'} = $collation_graph;
  98     bless( $self, $class );
  99
 100     # Now do the parsing.
 101     if( $format ) {
 102         my @args;
 103         if( $format =~ /^(CSV|CTE)$/ ) {
 104             @args = ( 'base' => $opts{'base'},
 105                       'data' => $opts{$format},
 106                       'format' => $format );
 107             $format = 'BaseText';
 108         } else {
 109             @args = ( $opts{ $format } );
 110         }
 111         my $mod = "Text::Tradition::Parser::$format";
 112         load( $mod );
 113         $mod->can('parse')->( $self, @args );
 114     }
 115     return $self;
 116 }
 117
 118 =item B<make_positions>
 119
 120 $graph->make_positions( $common_nodes, $paths )
 121
 122 Create an associated Graph::Positions object that records the position
 123 of each node in the graph.  This method call is probably in the wrong
 124 place and will move.
 125
 126 =cut
 127
 128 sub make_positions {
 129     my( $self, $common_nodes, $paths ) = @_;
 130     my $positions = Text::Tradition::Graph::Position->new( $common_nodes, $paths );
 131     $self->{'positions'} = $positions;
 132 }
 133
 134 =back
 135
 136 =head2 Graph::Easy object accessor methods
 137
 138 See the Graph::Easy documentation for descriptions of these functions.
 139
 140 =over
 141
 142 =item B<node>
 143
 144 =cut
 145
 146 sub node {
 147     my $self = shift;
 148     return $self->{'graph'}->node( @_ );
 149 }
 150
 151 =item B<edge>
 152
 153 =cut
 154
 155 sub edge {
 156     my $self = shift;
 157     return $self->{'graph'}->edge( @_ );
 158 }
 159
 160 =item B<add_node>
 161
 162 =cut
 163
 164 # Not only adds the node, but also initializes internal data
 165 # about the node.
 166
 167 sub add_node {
 168     my $self = shift;
 169     my $node = $self->{'graph'}->add_node( @_ );
 170     $self->{'identical_nodes'}->{ $node->name() } = [ $node->name() ];
 171     return $node;
 172 }
 173
 174 =item B<add_edge>
 175
 176 =cut
 177
 178 sub add_edge {
 179     my $self = shift;
 180     return $self->{'graph'}->add_edge( @_ );
 181 }
 182
 183 =item B<del_node>
 184
 185 =cut
 186
 187 sub del_node {
 188     my $self = shift;
 189     my $node = $_[0];
 190
 191     # Delete this node out of any relevant transposition pool.
 192     if( ref $node eq 'Graph::Easy::Node' ) {
 193         $node = $node->name();
 194     }
 195     my @ident = $self->identical_nodes( $node );
 196     if( @ident ) {
 197         # Get the pool.
 198         my $pool = $self->{'identical_nodes'}->{ $ident[0] };
 199         foreach my $i ( 0 .. scalar(@$pool)-1 ) {
 200             if( $pool->[$i] eq $node ) {
 201                 splice( @$pool, $i, 1 );
 202                 last;
 203             }
 204         }
 205     }
 206     delete $self->{'identical_nodes'}->{ $node };
 207
 208     # Now delete the node.
 209     return $self->{'graph'}->del_node( @_ );
 210 }
 211
 212 =item B<del_edge>
 213
 214 =cut
 215
 216 sub del_edge {
 217     my $self = shift;
 218     return $self->{'graph'}->del_edge( @_ );
 219 }
 220
 221 =item B<nodes>
 222
 223 =cut
 224
 225 sub nodes {
 226     my $self = shift;
 227     return $self->{'graph'}->nodes( @_ );
 228 }
 229
 230 =item B<edges>
 231
 232 =cut
 233
 234 sub edges {
 235     my $self = shift;
 236     return $self->{'graph'}->edges( @_ );
 237 }
 238
 239 =item B<merge_nodes>
 240
 241 =cut
 242
 243 sub merge_nodes {
 244     my $self = shift;
 245     return $self->{'graph'}->merge_nodes( @_ );
 246 }
 247
 248 ### Helper methods for navigating the tree
 249
 250 =back
 251
 252 =head2 Graph navigation methods
 253
 254 =over
 255
 256 =item B<start>
 257
 258 my $node = $graph->start();
 259
 260 Returns the beginning node of the graph.
 261
 262 =cut
 263
 264 sub start {
 265     # Return the beginning node of the graph.
 266     my $self = shift;
 267     my( $new_start ) = @_;
 268     if( $new_start ) {
 269         # Fix the node transposition data
 270         delete $self->{'identical_nodes'}->{ $new_start->name() };
 271         $self->{'identical_nodes'}->{'#START#'} = [ '#START#' ];
 272         $self->{'graph'}->rename_node( $new_start, '#START#' );
 273     }
 274     return $self->{'graph'}->node('#START#');
 275 }
 276
 277 =item B<next_word>
 278
 279 my $next_node = $graph->next_word( $node, $path );
 280
 281 Returns the node that follows the given node along the given witness
 282 path.  TODO These are badly named.
 283
 284 =cut
 285
 286 sub next_word {
 287     # Return the successor via the corresponding edge.
 288     my $self = shift;
 289     return $self->_find_linked_word( 'next', @_ );
 290 }
 291
 292 =item B<prior_word>
 293
 294 my $prior_node = $graph->prior_word( $node, $path );
 295
 296 Returns the node that precedes the given node along the given witness
 297 path.  TODO These are badly named.
 298
 299 =cut
 300
 301 sub prior_word {
 302     # Return the predecessor via the corresponding edge.
 303     my $self = shift;
 304     return $self->_find_linked_word( 'prior', @_ );
 305 }
 306
 307 sub _find_linked_word {
 308     my( $self, $direction, $node, $edge ) = @_;
 309     $edge = 'base text' unless $edge;
 310     my @linked_edges = $direction eq 'next'
 311         ? $node->outgoing() : $node->incoming();
 312     return undef unless scalar( @linked_edges );
 313
 314     # We have to find the linked edge that contains all of the
 315     # witnesses supplied in $edge.
 316     my @edge_wits = split( /, /, $edge );
 317     foreach my $le ( @linked_edges ) {
 318         my @le_wits = split( /, /, $le->name() );
 319         if( _is_within( \@edge_wits, \@le_wits ) ) {
 320             # This is the right edge.
 321             return $direction eq 'next' ? $le->to() : $le->from();
 322         }
 323     }
 324     warn "Could not find $direction node from " . $node->label
 325         . " along edge $edge";
 326     return undef;
 327 }
 328
 329 # Some set logic.
 330 sub _is_within {
 331     my( $set1, $set2 ) = @_;
 332     my $ret = 1;
 333     foreach my $el ( @$set1 ) {
 334         $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
 335     }
 336     return $ret;
 337 }
 338
 339 =item B<node_sequence>
 340
 341 my @nodes = $graph->node_sequence( $first, $last, $path );
 342
 343 Returns the ordered list of nodes, starting with $first and ending
 344 with $last, along the given witness path.
 345
 346 =cut
 347
 348 sub node_sequence {
 349     my( $self, $start, $end, $witness, $backup ) = @_;
 350     unless( ref( $start ) eq 'Graph::Easy::Node'
 351         && ref( $end ) eq 'Graph::Easy::Node' ) {
 352         warn "Called node_sequence without two nodes!";
 353         return ();
 354     }
 355     $witness = 'base text' unless $witness;
 356     my @nodes = ( $start );
 357     my %seen;
 358     my $n = $start;
 359     while( $n ne $end ) {
 360         if( exists( $seen{$n->name()} ) ) {
 361             warn "Detected loop at " . $n->name();
 362             last;
 363         }
 364         $seen{$n->name()} = 1;
 365
 366         my @edges = $n->outgoing();
 367         my @relevant_edges = grep { my @w = split( /, /, $_->label );
 368                                     grep { /^\Q$witness\E$/ } @w } @edges;
 369         unless( @relevant_edges ) {
 370             @relevant_edges = grep { my @w = split( /, /, $_->label );
 371                                      grep { /^\Q$backup\E$/ } @w } @edges
 372                                          if $backup;
 373         }
 374         unless( @relevant_edges ) {
 375             @relevant_edges = grep { $_->label() eq 'base text' } @edges;
 376         }
 377
 378         warn "Did not find an edge for $witness from node " . $n->label
 379             unless scalar @relevant_edges;
 380         my $next = $relevant_edges[0]->to();
 381         push( @nodes, $next );
 382         $n = $next;
 383     }
 384     # Check that the last node is our end node.
 385     my $last = $nodes[$#nodes];
 386     warn "Last node found from " . $start->label() .
 387         " for witness $witness is not the end!"
 388         unless $last eq $end;
 389
 390     return @nodes;
 391 }
 392
 393 =item B<string_lemma>
 394
 395 my $text = $graph->string_lemma( $first, $last, $path );
 396
 397 Returns the whitespace-separated text, starting with $first and ending
 398 with $last, represented in the graph along the given path.
 399
 400 =cut
 401
 402 sub string_lemma {
 403     my( $self, $start, $end, $label ) = @_;
 404
 405     my @nodes = $self->node_sequence( $start, $end, $label );
 406     my @words = map { $_->label() } @nodes;
 407     return join( ' ', @words );
 408 }
 409
 410 =back
 411
 412 =head2 Transposition handling methods
 413
 414 These should really move to their own module.  For use when the graph
 415 has split transposed nodes in order to avoid edges that travel
 416 backward.
 417
 418 =over
 419
 420 =item B<set_identical_node>
 421
 422 $graph->set_identical_node( $node, $other_node )
 423
 424 Tell the graph that these two nodes contain the same (transposed) reading.
 425
 426 =cut
 427
 428 sub set_identical_node {
 429     my( $self, $node, $same_node ) = @_;
 430     my $pool = $self->{'identical_nodes'}->{ $node };
 431     my $same_pool = $self->{'identical_nodes'}->{ $same_node };
 432     my %poolhash;
 433     foreach ( @$pool ) {
 434         $poolhash{$_} = 1;
 435     }
 436     foreach( @$same_pool ) {
 437         push( @$pool, $_ ) unless $poolhash{$_};
 438     }
 439
 440     $self->{'identical_nodes'}->{ $same_node } = $pool;
 441 }
 442
 443 =item B<set_identical_node>
 444
 445 my @nodes = $graph->identical_nodes( $node )
 446
 447 Get a list of nodes that contain the same (transposed) reading as the
 448 given node.
 449
 450 =cut
 451
 452 sub identical_nodes {
 453     my( $self, $node ) = @_;
 454     my @others = grep { $_ !~ /^$node$/ }
 455         @{$self->{'identical_nodes'}->{ $node }};
 456     return @others;
 457 }
 458
 459 =back
 460
 461 =head2 Output method(s)
 462
 463 =over
 464
 465 =item B<as_svg>
 466
 467 print $graph->as_svg( $recalculate );
 468
 469 Returns an SVG string that represents the graph.  Uses GraphViz to do
 470 this, because Graph::Easy doesn't cope well with long graphs. Unless
 471 $recalculate is passed (and is a true value), the method will return a
 472 cached copy of the SVG after the first call to the method.
 473
 474 =cut
 475
 476 sub as_svg {
 477     my( $self, $recalc ) = @_;
 478     return $self->{'svg'} if( exists $self->{'svg'} && !$recalc );
 479
 480     $self->{'graphviz'} = $self->{'graph'}->as_graphviz()
 481         unless( exists $self->{'graphviz'} && !$recalc );
 482
 483     my @cmd = qw/dot -Tsvg/;
 484     my( $svg, $err );
 485     my $in = $self->{'graphviz'};
 486     run( \@cmd, \$in, ">", binary(), \$svg );
 487     $self->{'svg'} = $svg;
 488     return $svg;
 489 }
 490
 491 =back
 492
 493 =head2 Lemmatization methods
 494
 495 =over
 496
 497 =item B<init_lemmatizer>
 498
 499 =cut
 500
 501 sub init_lemmatizer {
 502     my $self = shift;
 503     # Initialize the 'lemma' hash, going through all the nodes and seeing
 504     # which ones are common nodes.  This should only be run once.
 505
 506     return if( $self->{'lemmatizer_initialized'} );
 507     my @active_names = map { $_->name } grep { $self->is_common( $_ ) }
 508         $self->nodes();
 509     $self->{'positions'}->init_lemmatizer( @active_names );
 510     $self->{'lemmatizer_initialized'} = 1;
 511
 512 }
 513
 514 =item B<toggle_node>
 515
 516 my @nodes_turned_off = $graph->toggle_node( $node );
 517
 518 Takes a node name, and either lemmatizes or de-lemmatizes it. Returns
 519 a list of all nodes that are de-lemmatized as a result of the toggle.
 520
 521 =cut
 522
 523 sub toggle_node {
 524     my( $self, $node ) = @_;
 525
 526     # In case this is being called for the first time.
 527     $self->init_lemmatizer();
 528
 529     if( !$node || $self->is_common( $node ) ) {
 530         # Do nothing, it's a common node.
 531         return;
 532     }
 533
 534     my $pos = $self->{'positions'}->node_position( $node );
 535     my $old_state = $self->{'positions'}->state( $pos );
 536     my @nodes_off;
 537     if( $old_state && $old_state eq $node ) {
 538         # Turn off the node. We turn on no others by default.
 539         push( @nodes_off, $node );
 540     } else {
 541         # Turn on the node.
 542         $self->{'positions'}->set_state( $pos, $node );
 543         # Any other 'on' nodes in the same position should be off.
 544         push( @nodes_off, $self->colocated_nodes( $node ) );
 545         # Any node that is an identical transposed one should be off.
 546         push( @nodes_off, $self->identical_nodes( $node ) )
 547             if $self->identical_nodes( $node );
 548     }
 549     @nodes_off = unique_list( @nodes_off );
 550
 551     # Turn off the nodes that need to be turned off.
 552     my @nodes_turned_off;
 553     foreach my $n ( @nodes_off ) {
 554         my $npos = $self->{'positions'}->node_position( $n );
 555         my $state = $self->{'positions'}->state( $npos );
 556         if( $state && $state eq $n ) {
 557             # this node is still on
 558             push( @nodes_turned_off, $n );
 559             my $new_state = undef;
 560             if( $n eq $node ) {
 561                 # This is the node that was clicked, so if there are no
 562                 # other nodes there, turn off the position.  In all other
 563                 # cases, restore the ellipsis.
 564                 my @all_n = $self->{'positions'}->nodes_at_position( $pos );
 565                 $new_state = 0 if scalar( @all_n ) == 1;
 566             }
 567             $self->{'positions'}->set_state( $npos, $new_state );
 568         } elsif( $old_state && $old_state eq $n ) {
 569             # another node has already been turned on here
 570             push( @nodes_turned_off, $n );
 571         } # else some other node was on anyway, so pass.
 572     }
 573     return @nodes_turned_off;
 574 }
 575
 576 =item B<active_nodes>
 577
 578 my @state = $graph->active_nodes( @nodes_turned_off );
 579
 580 Takes a list of nodes that have just been turned off, and returns a
 581 set of tuples of the form ['node', 'state'] that indicates what
 582 changes need to be made to the graph.
 583
 584 =over
 585
 586 =item *
 587
 588 A state of 1 means 'turn on this node'
 589
 590 =item *
 591
 592 A state of 0 means 'turn off this node'
 593
 594 =item *
 595
 596 A state of undef means 'an ellipsis belongs in the text here because
 597 no decision has been made'
 598
 599 =back
 600
 601 =cut
 602
 603 sub active_nodes {
 604     my( $self, @toggled_off_nodes ) = @_;
 605
 606     # In case this is the first run
 607     $self->init_lemmatizer();
 608     # First get the positions of those nodes which have been
 609     # toggled off.
 610     my $positions_off = {};
 611     map { $positions_off->{ $self->{'positions'}->node_position( $_ ) } = $_ }
 612               @toggled_off_nodes;
 613
 614
 615     # Now for each position, we have to see if a node is on, and we
 616     # have to see if a node has been turned off.
 617     my @answer;
 618     foreach my $pos ( $self->{'positions'}->all() ) {
 619         # Find the state of this position.  If there is an active node,
 620         # its name will be the state; otherwise the state will be 0
 621         # (nothing at this position) or undef (ellipsis at this position)
 622         my $active = $self->{'positions'}->state( $pos );
 623
 624         # Is there a formerly active node that was toggled off?
 625         if( exists( $positions_off->{$pos} ) ) {
 626             my $off_node = $positions_off->{$pos};
 627             if( $active && $active ne $off_node) {
 628                 push( @answer, [ $off_node, 0 ], [ $active, 1 ] );
 629             } else {
 630                 push( @answer, [ $off_node, $active ] );
 631             }
 632
 633         # No formerly active node, so we just see if there is a currently
 634         # active one.
 635         } elsif( $active ) {
 636             # Push the active node, whatever it is.
 637             push( @answer, [ $active, 1 ] );
 638         } else {
 639             # Push the state that is there. Arbitrarily use the first node
 640             # at that position.
 641             my @pos_nodes = $self->{'positions'}->nodes_at_position( $pos );
 642             push( @answer,
 643                   [ $pos_nodes[0], $self->{'positions'}->state( $pos ) ] );
 644         }
 645     }
 646
 647     return @answer;
 648 }
 649
 650 # A couple of helpers.
 651
 652 sub is_common {
 653     my( $self, $node ) = @_;
 654     $node = $self->_nodeobj( $node );
 655     return $node->get_attribute('class') eq 'common';
 656 }
 657
 658 sub _nodeobj {
 659     my( $self, $node ) = @_;
 660     unless( ref $node eq 'Graph::Easy::Node' ) {
 661         $node = $self->node( $node );
 662     }
 663     return $node;
 664 }
 665
 666 sub colocated_nodes {
 667     my $self = shift;
 668     return $self->{'positions'}->colocated_nodes( @_ );
 669 }
 670
 671 sub text_of_node {
 672     my( $self, $node_id ) = @_;
 673     # This is the label of the given node.
 674     return $self->node( $node_id )->label();
 675 }
 676
 677 sub text_for_witness {
 678     my( $self, $wit ) = @_;
 679
 680     my @nodes = $self->{'positions'}->witness_path( $wit );
 681     my @words = map { $self->node( $_ )->label() } @nodes;
 682     return join( ' ', @words );
 683 }
 684
 685 sub unique_list {
 686     my( @list ) = @_;
 687     my %h;
 688     map { $h{$_} = 1 } @list;
 689     return keys( %h );
 690 }
 691
 692 =back
 693
 694 =head1 LICENSE
 695
 696 This package is free software and is provided "as is" without express
 697 or implied warranty.  You can redistribute it and/or modify it under
 698 the same terms as Perl itself.
 699
 700 =head1 AUTHOR
 701
 702 Tara L Andrews, aurum@cpan.org
 703
 704 =cut
 705
 706 1;
 707