lib/Traditions/Graph.pm

   1 package Traditions::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 Traditions::Graph::Position;
   9
  10 =head1 NAME
  11
  12 (Text?)::Traditions::Graph
  13
  14 =head1 SYNOPSIS
  15
  16 use Traditions::Graph;
  17
  18 my $text = Traditions::Graph->new( 'GraphML' => '/my/graphml/file.xml' );
  19 my $text = Traditions::Graph->new( 'TEI' => '/my/tei/file.xml' );
  20 my $text = Traditions::Graph->new( 'CSV' => '/my/csv/file.csv',
  21                                    'base' => '/my/basefile.txt' );
  22 my $text = Traditions::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 (someday)
  62 by CollateX, or a Classical Text Editor apparatus.  For CSV and
  63 Classical Text Editor files, the user must also supply a base text to
  64 which the line numbering in the collation file refers.
  65
  66 =cut
  67
  68 sub new {
  69     my $proto = shift;
  70     my $class = ref( $proto ) || $proto;
  71     my %opts = ( 'on_color' => 'yellow',
  72                  'off_color' => 'white',
  73                  @_ );
  74     my $self = {};
  75
  76     # opts can be: GraphML, base+CSV, base+CTE, TEI.  We need
  77     # something to parse.
  78     my @formats = grep { /^(GraphML|CSV|CTE|TEI)$/ } keys( %opts );
  79     my $format = shift( @formats );
  80     unless( $format ) {
  81         warn "No data given to create a graph: need GraphML, CSV, or TEI";
  82         return;
  83     }
  84     if( $format =~ /^(CSV|CTE)$/ && !exists $opts{'base'} ) {
  85         warn "Cannot make a graph from $format without a base text";
  86         return;
  87     }
  88
  89     # Make a graph object.
  90     my $collation_graph = Graph::Easy->new();
  91     $collation_graph->set_attribute( 'node', 'shape', 'ellipse' );
  92     # Starting point for all texts
  93     my $last_node = $collation_graph->add_node( '#START#' );
  94
  95     $self->{'graph'} = $collation_graph;
  96     bless( $self, $class );
  97
  98     # Now do the parsing.
  99     my $mod = "Traditions::Parser::$format";
 100     load( $mod );
 101     my @args = ( $opts{ $format } );
 102     if( $format =~ /^(CSV|CTE)$/ ) {
 103         push( @args, $opts{'base'} );
 104     }
 105     $mod->can('parse')->( $self, @args );
 106
 107     return $self;
 108 }
 109
 110
 111 ### Graph::Easy object accessor methods
 112 sub node {
 113     my $self = shift;
 114     return $self->{'graph'}->node( @_ );
 115 }
 116
 117 sub edge {
 118     my $self = shift;
 119     return $self->{'graph'}->edge( @_ );
 120 }
 121
 122 sub add_node {
 123     my $self = shift;
 124     return $self->{'graph'}->add_node( @_ );
 125 }
 126
 127 sub add_edge {
 128     my $self = shift;
 129     return $self->{'graph'}->add_edge( @_ );
 130 }
 131
 132 sub del_node {
 133     my $self = shift;
 134     return $self->{'graph'}->del_node( @_ );
 135 }
 136
 137 sub del_edge {
 138     my $self = shift;
 139     return $self->{'graph'}->del_edge( @_ );
 140 }
 141
 142 sub nodes {
 143     my $self = shift;
 144     return $self->{'graph'}->nodes( @_ );
 145 }
 146
 147 sub edges {
 148     my $self = shift;
 149     return $self->{'graph'}->edges( @_ );
 150 }
 151
 152 sub merge_nodes {
 153     my $self = shift;
 154     return $self->{'graph'}->merge_nodes( @_ );
 155 }
 156
 157 ### Helper methods for navigating the tree
 158
 159 sub start {
 160     # Return the beginning node of the graph.
 161     my $self = shift;
 162     my( $new_start ) = @_;
 163     if( $new_start ) {
 164         $self->{'graph'}->rename_node( $new_start, '#START#' );
 165     }
 166     return $self->{'graph'}->node('#START#');
 167 }
 168
 169 sub set_identical_nodes {
 170     my( $self, $node_hash ) = @_;
 171     $self->{'identical_nodes'} = $node_hash;
 172 }
 173
 174 sub next_word {
 175     # Return the successor via the corresponding edge.
 176     my( $self, $node, $edge ) = @_;
 177     $edge = "base text" unless $edge;
 178     my @next_edges = $node->outgoing();
 179     return undef unless scalar( @next_edges );
 180
 181     foreach my $e ( @next_edges ) {
 182         next unless $e->label() eq $edge;
 183         return $e->to();
 184     }
 185
 186     warn "Could not find node connected to edge $edge";
 187     return undef;
 188 }
 189
 190 sub prior_word {
 191     # Return the predecessor via the corresponding edge.
 192     my( $self, $node, $edge ) = @_;
 193     $edge = "base text" unless $edge;
 194     my @prior_edges = $node->incoming();
 195     return undef unless scalar( @prior_edges );
 196
 197     foreach my $e ( @prior_edges ) {
 198         next unless $e->label() eq $edge;
 199         return $e->from();
 200     }
 201
 202     warn "Could not find node connected from edge $edge";
 203     return undef;
 204 }
 205
 206 sub node_sequence {
 207     my( $self, $start, $end, $label ) = @_;
 208     # TODO make label able to follow a single MS
 209     unless( ref( $start ) eq 'Graph::Easy::Node'
 210         && ref( $end ) eq 'Graph::Easy::Node' ) {
 211         warn "Called node_sequence without two nodes!";
 212         return ();
 213     }
 214     $label = 'base text' unless $label;
 215     my @nodes = ( $start );
 216     my %seen;
 217     my $n = $start;
 218     while( $n ne $end ) {
 219         if( exists( $seen{$n->name()} ) ) {
 220             warn "Detected loop at " . $n->name();
 221             last;
 222         }
 223         $seen{$n->name()} = 1;
 224
 225         my @edges = $n->outgoing();
 226         my @relevant_edges = grep { $_->label =~ /^$label$/ } @edges;
 227         warn "Did not find an edge $label from node " . $n->label
 228             unless scalar @relevant_edges;
 229         warn "Found more than one edge $label from node " . $n->label
 230             unless scalar @relevant_edges == 1;
 231         my $next = $relevant_edges[0]->to();
 232         push( @nodes, $next );
 233         $n = $next;
 234     }
 235     # Check that the last node is our end node.
 236     my $last = $nodes[$#nodes];
 237     warn "Last node found from " . $start->label() .
 238         " via path $label is not the end!"
 239         unless $last eq $end;
 240
 241     return @nodes;
 242 }
 243
 244 sub string_lemma {
 245     my( $self, $start, $end, $label ) = @_;
 246
 247     my @nodes = $self->node_sequence( $start, $end, $label );
 248     my @words = map { $_->label() } @nodes;
 249     return join( ' ', @words );
 250 }
 251
 252 ## Output.  We use GraphViz for the layout because it handles large
 253 ## graphs better than Graph::Easy does natively.
 254
 255 sub as_svg {
 256     my( $self, $recalc ) = @_;
 257     return $self->{'svg'} if( exists $self->{'svg'} && !$recalc );
 258
 259     $self->{'graphviz'} = $self->{'graph'}->as_graphviz()
 260         unless( exists $self->{'graphviz'} && !$recalc );
 261
 262     my @cmd = qw/dot -Tsvg/;
 263     my( $svg, $err );
 264     my $in = $self->{'graphviz'};
 265     run( \@cmd, \$in, ">", binary(), \$svg );
 266     $self->{'svg'} = $svg;
 267     return $svg;
 268 }
 269
 270 ## Methods for lemmatizing a text.
 271
 272 sub init_lemmatizer {
 273     my $self = shift;
 274     # Initialize the 'lemma' hash, going through all the nodes and seeing
 275     # which ones are common nodes.  This should only be called once.
 276
 277     return if exists $self->{'lemma'};
 278
 279     my $lemma = {};
 280     foreach my $node ( $self->nodes() ) {
 281         my $state = $node->get_attribute('class') eq 'common' ? 1 : 0;
 282         $lemma->{ $node->name() } = $state;
 283     }
 284
 285     $self->{'lemma'} = $lemma;
 286 }
 287
 288 sub make_positions {
 289     my( $self, $common_nodes, $paths ) = @_;
 290     my $positions = Traditions::Graph::Position->new( $common_nodes, $paths );
 291     $self->{'positions'} = $positions;
 292 }
 293
 294 # Takes a list of nodes that have just been turned off, and returns a
 295 # set of tuples of the form ['node', 'state'] that indicates what
 296 # changes need to be made to the graph.
 297 # A state of 1 means 'turn on this node'
 298 # A state of 0 means 'turn off this node'
 299 # A state of undef means 'an ellipsis belongs in the text here because
 300 #   no decision has been made'
 301 sub active_nodes {
 302     my( $self, @toggled_off_nodes ) = @_;
 303
 304     # In case this is the first run
 305     $self->init_lemmatizer();
 306     # First get the positions of those nodes which have been
 307     # toggled off.
 308     my $positions_off = {};
 309     map { $positions_off->{ $self->{'positions'}->node_position( $_ ) } = $_ }
 310               @toggled_off_nodes;
 311
 312
 313     # Now for each position, we have to see if a node is on, and we
 314     # have to see if a node has been turned off.
 315     my @answer;
 316     foreach my $pos ( $self->{'positions'}->all() ) {
 317         my @nodes = $self->{'positions'}->nodes_at_position( $pos );
 318
 319         # See if there is an active node for this position.
 320         my @active_nodes = grep { $self->{'lemma'}->{$_} == 1 } @nodes;
 321         warn "More than one active node at position $pos!"
 322             unless scalar( @active_nodes ) < 2;
 323         my $active;
 324         if( scalar( @active_nodes ) ) {
 325             $active = $active_nodes[0] ;
 326         }
 327
 328         # Is there a formerly active node that was toggled off?
 329         if( exists( $positions_off->{$pos} ) ) {
 330             my $off_node = $positions_off->{$pos};
 331             if( $active ) {
 332                 push( @answer, [ $off_node, 0 ], [ $active, 1 ] );
 333             } elsif ( scalar @nodes == 1 ) {
 334                 # This was the only node at its position. No ellipsis.
 335                 push( @answer, [ $off_node, 0 ] );
 336             } else {
 337                 # More than one node at this position, none now active.
 338                 # Restore the ellipsis.
 339                 push( @answer, [ $off_node, undef ] );
 340             }
 341         # No formerly active node, so we just see if there is a currently
 342         # active one.
 343         } elsif( $active ) {
 344             # Push the active node, whatever it is.
 345             push( @answer, [ $active, 1 ] );
 346         } else {
 347             # There is no change here; we need an ellipsis. Use
 348             # the first node in the list, arbitrarily.
 349             push( @answer, [ $nodes[0] , undef ] );
 350         }
 351     }
 352
 353     return @answer;
 354 }
 355
 356 # A couple of helpers. TODO These should be gathered in the same place
 357 # eventually
 358
 359 sub is_common {
 360     my( $self, $node ) = @_;
 361     $node = $self->_nodeobj( $node );
 362     return $node->get_attribute('class') eq 'common';
 363 }
 364
 365 sub _nodeobj {
 366     my( $self, $node ) = @_;
 367     unless( ref $node eq 'Graph::Easy::Node' ) {
 368         $node = $self->node( $node );
 369     }
 370     return $node;
 371 }
 372
 373 # toggle_node takes a node name, and either lemmatizes or de-lemmatizes it.
 374 # Returns a list of nodes that are de-lemmatized as a result of the toggle.
 375
 376 sub toggle_node {
 377     my( $self, $node ) = @_;
 378
 379     # In case this is being called for the first time.
 380     $self->init_lemmatizer();
 381
 382     if( $self->is_common( $node ) ) {
 383         # Do nothing, it's a common node.
 384         return;
 385     }
 386
 387     my @nodes_off;
 388     # If we are about to turn on a node...
 389     if( !$self->{'lemma'}->{ $node } ) {
 390         # Turn on the node.
 391         $self->{'lemma'}->{ $node } = 1;
 392         # Turn off any other 'on' nodes in the same position.
 393         push( @nodes_off, $self->colocated_nodes( $node ) );
 394         # Turn off any node that is an identical transposed one.
 395         push( @nodes_off, $self->identical_nodes( $node ) )
 396             if $self->identical_nodes( $node );
 397     } else {
 398         push( @nodes_off, $node );
 399     }
 400     @nodes_off = unique_list( @nodes_off );
 401
 402     # Turn off the nodes that need to be turned off.
 403     map { $self->{'lemma'}->{$_} = 0 } @nodes_off;
 404     return @nodes_off;
 405 }
 406
 407 sub colocated_nodes {
 408     my $self = shift;
 409     return $self->{'positions'}->colocated_nodes( @_ );
 410 }
 411
 412 sub identical_nodes {
 413     my( $self, $node ) = @_;
 414     return undef unless exists $self->{'identical_nodes'} &&
 415         exists $self->{'identical_nodes'}->{$node};
 416     return $self->{'identical_nodes'}->{$node};
 417 }
 418
 419 sub text_of_node {
 420     my( $self, $node_id ) = @_;
 421     # This is the label of the given node.
 422     return $self->node( $node_id )->label();
 423 }
 424
 425 sub text_for_witness {
 426     my( $self, $wit ) = @_;
 427
 428     my @nodes = $self->{'positions'}->witness_path( $wit );
 429     my @words = map { $self->node( $_ )->label() } @nodes;
 430     return join( ' ', @words );
 431 }
 432
 433 sub unique_list {
 434     my( @list ) = @_;
 435     my %h;
 436     map { $h{$_} = 1 } @list;
 437     return keys( %h );
 438 }
 439
 440 1;
 441