lib/Text/Tradition/Collation.pm

   1 package Text::Tradition::Collation;
   2
   3 use Encode qw( decode_utf8 );
   4 use File::Temp;
   5 use Graph;
   6 use IPC::Run qw( run binary );
   7 use Text::CSV_XS;
   8 use Text::Tradition::Collation::Reading;
   9 use XML::LibXML;
  10 use Moose;
  11
  12 has 'sequence' => (
  13     is => 'ro',
  14     isa => 'Graph',
  15     default => sub { Graph->new() },
  16     handles => {
  17         paths => 'edges',
  18     },
  19     );
  20
  21 has 'relations' => (
  22         is => 'ro',
  23         isa => 'Graph',
  24         default => sub { Graph->new( undirected => 1 ) },
  25     handles => {
  26         relationships => 'edges',
  27     },
  28         );
  29
  30 has 'tradition' => (
  31     is => 'ro',
  32     isa => 'Text::Tradition',
  33     weak_ref => 1,
  34     );
  35
  36 has 'readings' => (
  37         isa => 'HashRef[Text::Tradition::Collation::Reading]',
  38         traits => ['Hash'],
  39     handles => {
  40         reading     => 'get',
  41         _add_reading => 'set',
  42         del_reading => 'delete',
  43         has_reading => 'exists',
  44         readings   => 'values',
  45     },
  46     default => sub { {} },
  47         );
  48
  49 has 'wit_list_separator' => (
  50     is => 'rw',
  51     isa => 'Str',
  52     default => ', ',
  53     );
  54
  55 has 'baselabel' => (
  56     is => 'rw',
  57     isa => 'Str',
  58     default => 'base text',
  59     );
  60
  61 has 'linear' => (
  62     is => 'rw',
  63     isa => 'Bool',
  64     default => 1,
  65     );
  66
  67 has 'ac_label' => (
  68     is => 'rw',
  69     isa => 'Str',
  70     default => ' (a.c.)',
  71     );
  72
  73 has 'start' => (
  74         is => 'ro',
  75         isa => 'Text::Tradition::Collation::Reading',
  76         writer => '_set_start',
  77         weak_ref => 1,
  78         );
  79
  80 has 'end' => (
  81         is => 'ro',
  82         isa => 'Text::Tradition::Collation::Reading',
  83         writer => '_set_end',
  84         weak_ref => 1,
  85         );
  86
  87 # The collation can be created two ways:
  88 # 1. Collate a set of witnesses (with CollateX I guess) and process
  89 #    the results as in 2.
  90 # 2. Read a pre-prepared collation in one of a variety of formats,
  91 #    and make the graph from that.
  92
  93 # The graph itself will (for now) be immutable, and the positions
  94 # within the graph will also be immutable.  We need to calculate those
  95 # positions upon graph construction.  The equivalences between graph
  96 # nodes will be mutable, entirely determined by the user (or possibly
  97 # by some semantic pre-processing provided by the user.)  So the
  98 # constructor should just make an empty equivalences object.  The
  99 # constructor will also need to make the witness objects, if we didn't
 100 # come through option 1.
 101
 102 sub BUILD {
 103     my $self = shift;
 104     $self->_set_start( $self->add_reading( { 'collation' => $self, 'is_start' => 1 } ) );
 105     $self->_set_end( $self->add_reading( { 'collation' => $self, 'is_end' => 1 } ) );
 106 }
 107
 108 ### Reading construct/destruct functions
 109
 110 sub add_reading {
 111         my( $self, $reading ) = @_;
 112         unless( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 113                 my %args = %$reading;
 114                 $reading = Text::Tradition::Collation::Reading->new(
 115                         'collation' => $self,
 116                         %args );
 117         }
 118         # First check to see if a reading with this ID exists.
 119         if( $self->reading( $reading->id ) ) {
 120                 warn "Collation already has a reading with id " . $reading->id;
 121                 return undef;
 122         }
 123         $self->_add_reading( $reading->id => $reading );
 124         # Once the reading has been added, put it in both graphs.
 125         $self->sequence->add_vertex( $reading->id );
 126         $self->relations->add_vertex( $reading->id );
 127         return $reading;
 128 };
 129
 130 around del_reading => sub {
 131         my $orig = shift;
 132         my $self = shift;
 133         my $arg = shift;
 134
 135         if( ref( $arg ) eq 'Text::Tradition::Collation::Reading' ) {
 136                 $arg = $arg->id;
 137         }
 138         # Remove the reading from the graphs.
 139         $self->sequence->delete_vertex( $arg );
 140         $self->relations->delete_vertex( $arg );
 141
 142         # Carry on.
 143         $self->$orig( $arg );
 144 };
 145
 146 # merge_readings( $main, $to_be_deleted );
 147
 148 sub merge_readings {
 149         my $self = shift;
 150
 151         # We only need the IDs for adding paths to the graph, not the reading
 152         # objects themselves.
 153     my( $kept, $deleted, $combine_char ) = $self->_stringify_args( @_ );
 154
 155     # The kept reading should inherit the paths and the relationships
 156     # of the deleted reading.
 157         foreach my $path ( $self->sequence->edges_at( $deleted ) ) {
 158                 my @vector = ( $kept );
 159                 push( @vector, $path->[1] ) if $path->[0] eq $deleted;
 160                 unshift( @vector, $path->[0] ) if $path->[1] eq $deleted;
 161                 next if $vector[0] eq $vector[1]; # Don't add a self loop
 162                 my %wits = %{$self->sequence->get_edge_attributes( @$path )};
 163                 $self->sequence->add_edge( @vector );
 164                 my $fwits = $self->sequence->get_edge_attributes( @vector );
 165                 @wits{keys %$fwits} = values %$fwits;
 166                 $self->sequence->set_edge_attributes( @vector, \%wits );
 167         }
 168         foreach my $rel ( $self->relations->edges_at( $deleted ) ) {
 169                 my @vector = ( $kept );
 170                 push( @vector, $rel->[0] eq $deleted ? $rel->[1] : $rel->[0] );
 171                 next if $vector[0] eq $vector[1]; # Don't add a self loop
 172                 # Is there a relationship here already? If so, keep it.
 173                 # TODO Warn about conflicting relationships
 174                 next if $self->relations->has_edge( @vector );
 175                 # If not, adopt the relationship that would be deleted.
 176                 $self->relations->add_edge( @vector );
 177                 my $attr = $self->relations->get_edge_attributes( @$rel );
 178                 $self->relations->set_edge_attributes( @vector, $attr );
 179         }
 180
 181         # Do the deletion deed.
 182         if( $combine_char ) {
 183                 my $kept_obj = $self->reading( $kept );
 184                 my $new_text = join( $combine_char, $kept_obj->text,
 185                         $self->reading( $deleted )->text );
 186                 $kept_obj->alter_text( $new_text );
 187         }
 188         $self->del_reading( $deleted );
 189 }
 190
 191
 192 # Helper function for manipulating the graph.
 193 sub _stringify_args {
 194         my( $self, $first, $second, $arg ) = @_;
 195     $first = $first->id
 196         if ref( $first ) eq 'Text::Tradition::Collation::Reading';
 197     $second = $second->id
 198         if ref( $second ) eq 'Text::Tradition::Collation::Reading';
 199     return( $first, $second, $arg );
 200 }
 201
 202 ### Path logic
 203
 204 sub add_path {
 205         my $self = shift;
 206
 207         # We only need the IDs for adding paths to the graph, not the reading
 208         # objects themselves.
 209     my( $source, $target, $wit ) = $self->_stringify_args( @_ );
 210
 211         # Connect the readings
 212     $self->sequence->add_edge( $source, $target );
 213     # Note the witness in question
 214     $self->sequence->set_edge_attribute( $source, $target, $wit, 1 );
 215 };
 216
 217 sub del_path {
 218         my $self = shift;
 219         my @args;
 220         if( ref( $_[0] ) eq 'ARRAY' ) {
 221                 my $e = shift @_;
 222                 @args = ( @$e, @_ );
 223         } else {
 224                 @args = @_;
 225         }
 226
 227         # We only need the IDs for adding paths to the graph, not the reading
 228         # objects themselves.
 229     my( $source, $target, $wit ) = $self->_stringify_args( @args );
 230
 231         if( $self->sequence->has_edge_attribute( $source, $target, $wit ) ) {
 232                 $self->sequence->delete_edge_attribute( $source, $target, $wit );
 233         }
 234         unless( keys %{$self->sequence->get_edge_attributes( $source, $target )} ) {
 235                 $self->sequence->delete_edge( $source, $target );
 236         }
 237 }
 238
 239
 240 # Extra graph-alike utility
 241 sub has_path {
 242         my $self = shift;
 243     my( $source, $target, $wit ) = $self->_stringify_args( @_ );
 244         return undef unless $self->sequence->has_edge( $source, $target );
 245         return $self->sequence->has_edge_attribute( $source, $target, $wit );
 246 }
 247
 248 ### Relationship logic
 249
 250 =head2 add_relationship( $reading1, $reading2, $definition )
 251
 252 Adds the specified relationship between the two readings.  A relationship
 253 is transitive (i.e. undirected), and must have the following attributes
 254 specified in the hashref $definition:
 255
 256 =over 4
 257
 258 =item * type - Can be one of spelling, orthographic, grammatical, meaning, lexical, collated, repetition, transposition.  All but the last two are only valid relationships between readings that occur at the same point in the text.
 259
 260 =item * non_correctable - (Optional) True if the reading would not have been corrected independently.
 261
 262 =item * non_independent - (Optional) True if the variant is unlikely to have occurred independently in unrelated witnesses.
 263
 264 =item * global - (Optional) A meta-attribute, to set the same relationship between readings with the same text whenever they occur in the same place.
 265
 266 =back
 267
 268 =cut
 269
 270 # Wouldn't it be lovely if edges could be objects, and all this type checking
 271 # and attribute management could be done via Moose?
 272
 273 sub add_relationship {
 274         my $self = shift;
 275     my( $source, $target, $options ) = $self->_stringify_args( @_ );
 276
 277         # Check the options
 278         if( !defined $options->{'type'} ||
 279                 $options->{'type'} !~ /^(spelling|orthographic|grammatical|meaning|lexical|collated|repetition|transposition)$/i ) {
 280                 my $t = $options->{'type'} ? $options->{'type'} : '';
 281                 return( undef, "Invalid or missing type " . $options->{'type'} );
 282         }
 283         unless ( $options->{'type'} =~ /^(repetition|transposition)$/ ) {
 284                 $options->{'colocated'} = 1;
 285         }
 286
 287     # Make sure there is not another relationship between these two
 288     # readings already
 289     if( $self->relations->has_edge( $source, $target ) ) {
 290                 return ( undef, "Relationship already exists between these readings" );
 291     }
 292     if( !$self->relationship_valid( $source, $target, $options->{'type'} ) ) {
 293         return ( undef, 'Relationship creates witness loop' );
 294     }
 295
 296         my @vector = ( $source, $target );
 297         $self->relations->add_edge( @vector );
 298         $self->relations->set_edge_attributes( @vector, $options );
 299
 300     # TODO Handle global relationship setting
 301
 302     return( 1, @vector );
 303 }
 304
 305 sub relationship_valid {
 306     my( $self, $source, $target, $rel ) = @_;
 307     if( $rel eq 'repetition' ) {
 308         return 1;
 309         } elsif ( $rel eq 'transposition' ) {
 310                 # Check that the two readings do not appear in the same witness.
 311                 my %seen_wits;
 312                 map { $seen_wits{$_} = 1 } $self->reading_witnesses( $source );
 313                 foreach my $w ( $self->reading_witnesses( $target ) ) {
 314                         return 0 if $seen_wits{$w};
 315                 }
 316                 return 1;
 317         } else {
 318                 # Check that linking the source and target in a relationship won't lead
 319                 # to a path loop for any witness.  First make a lookup table of all the
 320                 # readings related to either the source or the target.
 321                 my @proposed_related = ( $source, $target );
 322                 push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
 323                 push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
 324                 my %pr_ids;
 325                 map { $pr_ids{ $_ } = 1 } @proposed_related;
 326
 327                 # None of these proposed related readings should have a neighbor that
 328                 # is also in proposed_related.
 329                 foreach my $pr ( keys %pr_ids ) {
 330                         foreach my $neighbor( $self->sequence->neighbors( $pr ) ) {
 331                                 return 0 if exists $pr_ids{$neighbor};
 332                         }
 333                 }
 334                 return 1;
 335         }
 336 }
 337
 338 # Return a list of the witnesses in which the reading appears.
 339 sub reading_witnesses {
 340         my( $self, $reading ) = @_;
 341         # We need only check either the incoming or the outgoing edges; I have
 342         # arbitrarily chosen "incoming".
 343         my %all_witnesses;
 344         foreach my $e ( $self->sequence->edges_to( $reading ) ) {
 345                 my $wits = $self->sequence->get_edge_attributes( @$e );
 346                 @all_witnesses{ keys %$wits } = 1;
 347         }
 348         return keys %all_witnesses;
 349 }
 350
 351 sub related_readings {
 352         my( $self, $reading, $colocated ) = @_;
 353         my $return_object;
 354         if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
 355                 $reading = $reading->id;
 356                 $return_object = 1;
 357 #               print STDERR "Returning related objects\n";
 358 #       } else {
 359 #               print STDERR "Returning related object names\n";
 360         }
 361         my @related = $self->relations->all_reachable( $reading );
 362         if( $colocated ) {
 363                 my @colo = grep { $self->relations->has_edge_attribute( $reading, $_, 'colocated' ) } @related;
 364                 @related = @colo;
 365         }
 366         return $return_object ? map { $self->reading( $_ ) } @related : @related;
 367 }
 368
 369 =head2 Output method(s)
 370
 371 =over
 372
 373 =item B<as_svg>
 374
 375 print $graph->as_svg( $recalculate );
 376
 377 Returns an SVG string that represents the graph, via as_dot and graphviz.
 378
 379 =cut
 380
 381 sub as_svg {
 382     my( $self ) = @_;
 383
 384     my @cmd = qw/dot -Tsvg/;
 385     my( $svg, $err );
 386     my $dotfile = File::Temp->new();
 387     ## TODO REMOVE
 388     # $dotfile->unlink_on_destroy(0);
 389     binmode $dotfile, ':utf8';
 390     print $dotfile $self->as_dot();
 391     push( @cmd, $dotfile->filename );
 392     run( \@cmd, ">", binary(), \$svg );
 393     $svg = decode_utf8( $svg );
 394     return $svg;
 395 }
 396
 397 =item B<as_dot>
 398
 399 print $graph->as_dot( $view, $recalculate );
 400
 401 Returns a string that is the collation graph expressed in dot
 402 (i.e. GraphViz) format.  The 'view' argument determines what kind of
 403 graph is produced.
 404     * 'path': a graph of witness paths through the collation (DEFAULT)
 405     * 'relationship': a graph of how collation readings relate to
 406       each other
 407
 408 =cut
 409
 410 sub as_dot {
 411     my( $self, $view ) = @_;
 412     $view = 'sequence' unless $view;
 413     # TODO consider making some of these things configurable
 414     my $graph_name = $self->tradition->name;
 415     $graph_name =~ s/[^\w\s]//g;
 416     $graph_name = join( '_', split( /\s+/, $graph_name ) );
 417     my $dot = sprintf( "digraph %s {\n", $graph_name );
 418     $dot .= "\tedge [ arrowhead=open ];\n";
 419     $dot .= "\tgraph [ rankdir=LR ];\n";
 420     $dot .= sprintf( "\tnode [ fontsize=%d, fillcolor=%s, style=%s, shape=%s ];\n",
 421                      11, "white", "filled", "ellipse" );
 422
 423     foreach my $reading ( $self->readings ) {
 424         # Need not output nodes without separate labels
 425         next if $reading->id eq $reading->text;
 426         my $label = $reading->text;
 427         $label =~ s/\"/\\\"/g;
 428         $dot .= sprintf( "\t\"%s\" [ label=\"%s\" ];\n", $reading->id, $label );
 429     }
 430
 431     # TODO do something sensible for relationships
 432
 433     my @edges = $self->paths;
 434     foreach my $edge ( @edges ) {
 435         my %variables = ( 'color' => '#000000',
 436                           'fontcolor' => '#000000',
 437                           'label' => join( ', ', $self->path_display_label( $edge ) ),
 438             );
 439         my $varopts = join( ', ', map { $_.'="'.$variables{$_}.'"' } sort keys %variables );
 440         # Account for the rank gap if necessary
 441         my $rankgap = $self->reading( $edge->[1] )->rank
 442                 - $self->reading( $edge->[0] )->rank;
 443                 $varopts .= ", minlen=$rankgap" if $rankgap > 1;
 444         $dot .= sprintf( "\t\"%s\" -> \"%s\" [ %s ];\n",
 445                          $edge->[0], $edge->[1], $varopts );
 446     }
 447     $dot .= "}\n";
 448     return $dot;
 449 }
 450
 451 sub path_witnesses {
 452         my( $self, @edge ) = @_;
 453         # If edge is an arrayref, cope.
 454         if( @edge == 1 && ref( $edge[0] ) eq 'ARRAY' ) {
 455                 my $e = shift @edge;
 456                 @edge = @$e;
 457         }
 458         my @wits = keys %{$self->sequence->get_edge_attributes( @edge )};
 459         return sort @wits;
 460 }
 461
 462 sub path_display_label {
 463         my( $self, $edge ) = @_;
 464         my @wits = $self->path_witnesses( $edge );
 465         my $maj = scalar( $self->tradition->witnesses ) * 0.6;
 466         if( scalar @wits > $maj ) {
 467                 return 'majority';
 468         } else {
 469                 return join( ', ', @wits );
 470         }
 471 }
 472
 473
 474 =item B<as_graphml>
 475
 476 print $graph->as_graphml( $recalculate )
 477
 478 Returns a GraphML representation of the collation graph, with
 479 transposition information and position information. Unless
 480 $recalculate is passed (and is a true value), the method will return a
 481 cached copy of the SVG after the first call to the method.
 482
 483 =cut
 484
 485 sub as_graphml {
 486     my( $self ) = @_;
 487
 488     # Some namespaces
 489     my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
 490     my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
 491     my $graphml_schema = 'http://graphml.graphdrawing.org/xmlns ' .
 492         'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
 493
 494     # Create the document and root node
 495     my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
 496     my $root = $graphml->createElementNS( $graphml_ns, 'graphml' );
 497     $graphml->setDocumentElement( $root );
 498     $root->setNamespace( $xsi_ns, 'xsi', 0 );
 499     $root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
 500
 501     # Add the data keys for the graph
 502     my %graph_data_keys;
 503     my $gdi = 0;
 504     my @graph_attributes = qw/ version wit_list_separator baselabel linear ac_label /;
 505     foreach my $datum ( @graph_attributes ) {
 506         $graph_data_keys{$datum} = 'dg'.$gdi++;
 507         my $key = $root->addNewChild( $graphml_ns, 'key' );
 508         $key->setAttribute( 'attr.name', $datum );
 509         $key->setAttribute( 'attr.type', $key eq 'linear' ? 'boolean' : 'string' );
 510         $key->setAttribute( 'for', 'graph' );
 511         $key->setAttribute( 'id', $graph_data_keys{$datum} );
 512     }
 513
 514     # Add the data keys for nodes
 515     my %node_data_keys;
 516     my $ndi = 0;
 517     my %node_data = (
 518         id => 'string',
 519         text => 'string',
 520         rank => 'string',
 521         is_start => 'boolean',
 522         is_end => 'boolean',
 523         is_lacuna => 'boolean',
 524         );
 525     foreach my $datum ( keys %node_data ) {
 526         $node_data_keys{$datum} = 'dn'.$ndi++;
 527         my $key = $root->addNewChild( $graphml_ns, 'key' );
 528         $key->setAttribute( 'attr.name', $datum );
 529         $key->setAttribute( 'attr.type', $node_data{$datum} );
 530         $key->setAttribute( 'for', 'node' );
 531         $key->setAttribute( 'id', $node_data_keys{$datum} );
 532     }
 533
 534     # Add the data keys for edges, i.e. witnesses
 535     my $edi = 0;
 536     my %edge_data_keys;
 537     my %edge_data = (
 538         witness => 'string',                    # ID/label for a path
 539         relationship => 'string',               # ID/label for a relationship
 540         extra => 'boolean',                             # Path key
 541         colocated => 'boolean',                 # Relationship key
 542         non_correctable => 'boolean',   # Relationship key
 543         non_independent => 'boolean',   # Relationship key
 544         );
 545     foreach my $datum ( keys %edge_data ) {
 546         $edge_data_keys{$datum} = 'de'.$edi++;
 547         my $key = $root->addNewChild( $graphml_ns, 'key' );
 548         $key->setAttribute( 'attr.name', $datum );
 549         $key->setAttribute( 'attr.type', $edge_data{$datum} );
 550         $key->setAttribute( 'for', 'edge' );
 551         $key->setAttribute( 'id', $edge_data_keys{$datum} );
 552     }
 553
 554     # Add the collation graphs themselves
 555     my $sgraph = $root->addNewChild( $graphml_ns, 'graph' );
 556     $sgraph->setAttribute( 'edgedefault', 'directed' );
 557     $sgraph->setAttribute( 'id', $self->tradition->name );
 558     $sgraph->setAttribute( 'parse.edgeids', 'canonical' );
 559     $sgraph->setAttribute( 'parse.edges', scalar($self->paths) );
 560     $sgraph->setAttribute( 'parse.nodeids', 'canonical' );
 561     $sgraph->setAttribute( 'parse.nodes', scalar($self->readings) );
 562     $sgraph->setAttribute( 'parse.order', 'nodesfirst' );
 563
 564     my $rgraph = $root->addNewChild( $graphml_ns, 'graph' );
 565     $rgraph->setAttribute( 'edgedefault', 'undirected' );
 566     $rgraph->setAttribute( 'id', 'relationships' );
 567     $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
 568     $rgraph->setAttribute( 'parse.edges', scalar($self->relationships) );
 569     $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
 570     $rgraph->setAttribute( 'parse.nodes', scalar($self->readings) );
 571     $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
 572
 573     # Collation attribute data
 574     foreach my $datum ( @graph_attributes ) {
 575         my $value = $datum eq 'version' ? '3.0' : $self->$datum;
 576                 _add_graphml_data( $sgraph, $graph_data_keys{$datum}, $value );
 577         }
 578
 579     my $node_ctr = 0;
 580     my %node_hash;
 581     # Add our readings to the graphs
 582     foreach my $n ( sort { $a->id cmp $b->id } $self->readings ) {
 583         # Add to the main graph
 584         my $node_el = $sgraph->addNewChild( $graphml_ns, 'node' );
 585         my $node_xmlid = 'n' . $node_ctr++;
 586         $node_hash{ $n->id } = $node_xmlid;
 587         $node_el->setAttribute( 'id', $node_xmlid );
 588         foreach my $d ( keys %node_data ) {
 589                 my $nval = $n->$d;
 590                 _add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
 591                         if defined $nval;
 592         }
 593         # Add to the relationships graph
 594         my $rnode_el = $rgraph->addNewChild( $graphml_ns, 'node' );
 595         $rnode_el->setAttribute( 'id', $node_xmlid );
 596     }
 597
 598     # Add the path edges to the sequence graph
 599     my $edge_ctr = 0;
 600     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->sequence->edges() ) {
 601         # We add an edge in the graphml for every witness in $e.
 602         foreach my $wit ( $self->path_witnesses( $e ) ) {
 603                         my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
 604                                                                                 $node_hash{ $e->[0] },
 605                                                                                 $node_hash{ $e->[1] } );
 606                         my $edge_el = $sgraph->addNewChild( $graphml_ns, 'edge' );
 607                         $edge_el->setAttribute( 'source', $from );
 608                         $edge_el->setAttribute( 'target', $to );
 609                         $edge_el->setAttribute( 'id', $id );
 610
 611                         # It's a witness path, so add the witness
 612                         my $base = $wit;
 613                         my $key = $edge_data_keys{'witness'};
 614                         # Is this an ante-corr witness?
 615                         my $aclabel = $self->ac_label;
 616                         if( $wit =~ /^(.*)\Q$aclabel\E$/ ) {
 617                                 # Keep the base witness
 618                                 $base = $1;
 619                                 # ...and record that this is an 'extra' reading path
 620                                 _add_graphml_data( $edge_el, $edge_data_keys{'extra'}, $aclabel );
 621                         }
 622                         _add_graphml_data( $edge_el, $edge_data_keys{'witness'}, $base );
 623                 }
 624         }
 625
 626         # Add the relationship edges to the relationships graph
 627         foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->relationships ) {
 628                 my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
 629                                                                         $node_hash{ $e->[0] },
 630                                                                         $node_hash{ $e->[1] } );
 631                 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
 632                 $edge_el->setAttribute( 'source', $from );
 633                 $edge_el->setAttribute( 'target', $to );
 634                 $edge_el->setAttribute( 'id', $id );
 635
 636                 my $data = $self->relations->get_edge_attributes( @$e );
 637                 # It's a relationship, so save the relationship data
 638                 _add_graphml_data( $edge_el, $edge_data_keys{'relationship'}, $data->{type} );
 639                 _add_graphml_data( $edge_el, $edge_data_keys{'colocated'}, $data->{colocated} );
 640                 if( exists $data->{non_correctable} ) {
 641                         _add_graphml_data( $edge_el, $edge_data_keys{'non_correctable'},
 642                                 $data->{non_correctable} );
 643                 }
 644                 if( exists $data->{non_independent} ) {
 645                         _add_graphml_data( $edge_el, $edge_data_keys{'non_independent'},
 646                                 $data->{non_independent} );
 647                 }
 648     }
 649
 650     # Save and return the thing
 651     my $result = decode_utf8( $graphml->toString(1) );
 652     return $result;
 653 }
 654
 655 sub _add_graphml_data {
 656     my( $el, $key, $value ) = @_;
 657     return unless defined $value;
 658     my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
 659     $data_el->setAttribute( 'key', $key );
 660     $data_el->appendText( $value );
 661 }
 662
 663 =item B<as_csv>
 664
 665 print $graph->as_csv( $recalculate )
 666
 667 Returns a CSV alignment table representation of the collation graph, one
 668 row per witness (or witness uncorrected.)
 669
 670 =cut
 671
 672 sub as_csv {
 673     my( $self ) = @_;
 674     my $table = $self->make_alignment_table;
 675     my $csv = Text::CSV_XS->new( { binary => 1, quote_null => 0 } );
 676     my @result;
 677     # Make the header row
 678     $csv->combine( map { $_->{'witness'} } @{$table->{'alignment'}} );
 679         push( @result, decode_utf8( $csv->string ) );
 680     # Make the rest of the rows
 681     foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
 682         my @rowobjs = map { $_->[$idx] } @{$table->{'alignment'}};
 683         my @row = map { $_ ? $_->{'t'} : $_ } @rowobjs;
 684         $csv->combine( @row );
 685         push( @result, decode_utf8( $csv->string ) );
 686     }
 687     return join( "\n", @result );
 688 }
 689
 690 =item B<make_alignment_table>
 691
 692 my $table = $graph->make_alignment_table( $use_refs, \@wits_to_include )
 693
 694 Return a reference to an alignment table, in the format described at
 695 L<http://gregor.middell.net/collatex>.  If $use_refs is set to 1, the reading
 696 object is returned in the table; if not, the text of the reading is returned.
 697 If $wits_to_include is set to an arrayref, only the witnesses listed will be
 698 included in the table.
 699
 700 =cut
 701
 702 sub make_alignment_table {
 703     my( $self, $noderefs, $include ) = @_;
 704     unless( $self->linear ) {
 705         warn "Need a linear graph in order to make an alignment table";
 706         return;
 707     }
 708     my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
 709     my @all_pos = ( 1 .. $self->end->rank - 1 );
 710     foreach my $wit ( $self->tradition->witnesses ) {
 711         if( $include ) {
 712                 next unless grep { $_ eq $wit->sigil } @$include;
 713         }
 714         $DB::single = 1 if $wit->sigil eq 'U';
 715         # print STDERR "Making witness row(s) for " . $wit->sigil . "\n";
 716         my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
 717         my @row = _make_witness_row( \@wit_path, \@all_pos, $noderefs );
 718         push( @{$table->{'alignment'}},
 719                 { 'witness' => $wit->sigil, 'tokens' => \@row } );
 720         if( $wit->is_layered ) {
 721                 my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
 722                         $wit->sigil.$self->ac_label, $wit->sigil );
 723             my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos, $noderefs );
 724                         push( @{$table->{'alignment'}},
 725                                 { 'witness' => $wit->sigil.$self->ac_label, 'tokens' => \@ac_row } );
 726         }
 727     }
 728         return $table;
 729 }
 730
 731 sub _make_witness_row {
 732     my( $path, $positions, $noderefs ) = @_;
 733     my %char_hash;
 734     map { $char_hash{$_} = undef } @$positions;
 735     my $debug = 0;
 736     foreach my $rdg ( @$path ) {
 737         my $rtext = $rdg->text;
 738         $rtext = '#LACUNA#' if $rdg->is_lacuna;
 739         print STDERR "rank " . $rdg->rank . "\n" if $debug;
 740         # print STDERR "No rank for " . $rdg->id . "\n" unless defined $rdg->rank;
 741         $char_hash{$rdg->rank} = $noderefs ? { 't' => $rdg }
 742                                                                            : { 't' => $rtext };
 743     }
 744     my @row = map { $char_hash{$_} } @$positions;
 745     # Fill in lacuna markers for undef spots in the row
 746     my $last_el = shift @row;
 747     my @filled_row = ( $last_el );
 748     foreach my $el ( @row ) {
 749         # If we are using node reference, make the lacuna node appear many times
 750         # in the table.  If not, use the lacuna tag.
 751         if( $last_el && _el_is_lacuna( $last_el ) && !defined $el ) {
 752             $el = $noderefs ? { 't' => $last_el } : { 't' => '#LACUNA#' };
 753         }
 754         push( @filled_row, $el );
 755         $last_el = $el;
 756     }
 757     return @filled_row;
 758 }
 759
 760 # Tiny utility function to say if a table element is a lacuna
 761 sub _el_is_lacuna {
 762     my $el = shift;
 763     return 1 if $el->{'t'} eq '#LACUNA#';
 764     return 1 if ref( $el->{'t'} ) eq 'Text::Tradition::Collation::Reading'
 765         && $el->{'t'}->is_lacuna;
 766     return 0;
 767 }
 768
 769 # Helper to turn the witnesses along columns rather than rows.  Assumes
 770 # equal-sized rows.
 771 sub _turn_table {
 772     my( $table ) = @_;
 773     my $result = [];
 774     return $result unless scalar @$table;
 775     my $nrows = scalar @{$table->[0]};
 776     foreach my $idx ( 0 .. $nrows - 1 ) {
 777         foreach my $wit ( 0 .. $#{$table} ) {
 778             $result->[$idx]->[$wit] = $table->[$wit]->[$idx];
 779         }
 780     }
 781     return $result;
 782 }
 783
 784 =back
 785
 786 =head2 Navigation methods
 787
 788 =over
 789
 790 =item B<start>
 791
 792 my $beginning = $collation->start();
 793
 794 Returns the beginning of the collation, a meta-reading with label '#START#'.
 795
 796 =item B<end>
 797
 798 my $end = $collation->end();
 799
 800 Returns the end of the collation, a meta-reading with label '#END#'.
 801
 802
 803 =item B<reading_sequence>
 804
 805 my @readings = $graph->reading_sequence( $first, $last, $path[, $alt_path] );
 806
 807 Returns the ordered list of readings, starting with $first and ending
 808 with $last, along the given witness path.  If no path is specified,
 809 assume that the path is that of the base text (if any.)
 810
 811 =cut
 812
 813 # TODO Think about returning some lazy-eval iterator.
 814
 815 sub reading_sequence {
 816     my( $self, $start, $end, $witness, $backup ) = @_;
 817
 818     $witness = $self->baselabel unless $witness;
 819     my @readings = ( $start );
 820     my %seen;
 821     my $n = $start;
 822     while( $n && $n->id ne $end->id ) {
 823         if( exists( $seen{$n->id} ) ) {
 824             warn "Detected loop at " . $n->id;
 825             last;
 826         }
 827         $seen{$n->id} = 1;
 828
 829         my $next = $self->next_reading( $n, $witness, $backup );
 830         unless( $next ) {
 831             warn "Did not find any path for $witness from reading " . $n->id;
 832             last;
 833         }
 834         push( @readings, $next );
 835         $n = $next;
 836     }
 837     # Check that the last reading is our end reading.
 838     my $last = $readings[$#readings];
 839     warn "Last reading found from " . $start->text .
 840         " for witness $witness is not the end!"
 841         unless $last->id eq $end->id;
 842
 843     return @readings;
 844 }
 845
 846 =item B<next_reading>
 847
 848 my $next_reading = $graph->next_reading( $reading, $witpath );
 849
 850 Returns the reading that follows the given reading along the given witness
 851 path.
 852
 853 =cut
 854
 855 sub next_reading {
 856     # Return the successor via the corresponding path.
 857     my $self = shift;
 858     my $answer = $self->_find_linked_reading( 'next', @_ );
 859         return undef unless $answer;
 860     return $self->reading( $answer );
 861 }
 862
 863 =item B<prior_reading>
 864
 865 my $prior_reading = $graph->prior_reading( $reading, $witpath );
 866
 867 Returns the reading that precedes the given reading along the given witness
 868 path.
 869
 870 =cut
 871
 872 sub prior_reading {
 873     # Return the predecessor via the corresponding path.
 874     my $self = shift;
 875     my $answer = $self->_find_linked_reading( 'prior', @_ );
 876     return $self->reading( $answer );
 877 }
 878
 879 sub _find_linked_reading {
 880     my( $self, $direction, $node, $path, $alt_path ) = @_;
 881     my @linked_paths = $direction eq 'next'
 882         ? $self->sequence->edges_from( $node )
 883         : $self->sequence->edges_to( $node );
 884     return undef unless scalar( @linked_paths );
 885
 886     # We have to find the linked path that contains all of the
 887     # witnesses supplied in $path.
 888     my( @path_wits, @alt_path_wits );
 889     @path_wits = sort( $self->witnesses_of_label( $path ) ) if $path;
 890     @alt_path_wits = sort( $self->witnesses_of_label( $alt_path ) ) if $alt_path;
 891     my $base_le;
 892     my $alt_le;
 893     foreach my $le ( @linked_paths ) {
 894         if( $self->sequence->has_edge_attribute( @$le, $self->baselabel ) ) {
 895             $base_le = $le;
 896         }
 897                 my @le_wits = $self->path_witnesses( $le );
 898                 if( _is_within( \@path_wits, \@le_wits ) ) {
 899                         # This is the right path.
 900                         return $direction eq 'next' ? $le->[1] : $le->[0];
 901                 } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
 902                         $alt_le = $le;
 903                 }
 904     }
 905     # Got this far? Return the alternate path if it exists.
 906     return $direction eq 'next' ? $alt_le->[1] : $alt_le->[0]
 907         if $alt_le;
 908
 909     # Got this far? Return the base path if it exists.
 910     return $direction eq 'next' ? $base_le->[1] : $base_le->[0]
 911         if $base_le;
 912
 913     # Got this far? We have no appropriate path.
 914     warn "Could not find $direction node from " . $node->id
 915         . " along path $path";
 916     return undef;
 917 }
 918
 919 # Some set logic.
 920 sub _is_within {
 921     my( $set1, $set2 ) = @_;
 922     my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
 923     foreach my $el ( @$set1 ) {
 924         $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
 925     }
 926     return $ret;
 927 }
 928
 929
 930 ## INITIALIZATION METHODS - for use by parsers
 931
 932 # For use when a collation is constructed from a base text and an apparatus.
 933 # We have the sequences of readings and just need to add path edges.
 934 # When we are done, clear out the witness path attributes, as they are no
 935 # longer needed.
 936 # TODO Find a way to replace the witness path attributes with encapsulated functions?
 937
 938 sub make_witness_paths {
 939     my( $self ) = @_;
 940     foreach my $wit ( $self->tradition->witnesses ) {
 941         # print STDERR "Making path for " . $wit->sigil . "\n";
 942         $self->make_witness_path( $wit );
 943     }
 944 }
 945
 946 sub make_witness_path {
 947     my( $self, $wit ) = @_;
 948     my @chain = @{$wit->path};
 949     my $sig = $wit->sigil;
 950     foreach my $idx ( 0 .. $#chain-1 ) {
 951         $self->add_path( $chain[$idx], $chain[$idx+1], $sig );
 952     }
 953     if( $wit->is_layered ) {
 954         @chain = @{$wit->uncorrected_path};
 955         foreach my $idx( 0 .. $#chain-1 ) {
 956             my $source = $chain[$idx];
 957             my $target = $chain[$idx+1];
 958             $self->add_path( $source, $target, $sig.$self->ac_label )
 959                 unless $self->has_path( $source, $target, $sig );
 960         }
 961     }
 962     $wit->clear_path;
 963     $wit->clear_uncorrected_path;
 964 }
 965
 966 sub calculate_ranks {
 967     my $self = shift;
 968     # Walk a version of the graph where every node linked by a relationship
 969     # edge is fundamentally the same node, and do a topological ranking on
 970     # the nodes in this graph.
 971     my $topo_graph = Graph->new();
 972     my %rel_containers;
 973     my $rel_ctr = 0;
 974     # Add the nodes
 975     foreach my $r ( $self->readings ) {
 976         next if exists $rel_containers{$r->id};
 977         my @rels = $r->related_readings( 'colocated' );
 978         if( @rels ) {
 979             # Make a relationship container.
 980             push( @rels, $r );
 981             my $rn = 'rel_container_' . $rel_ctr++;
 982             $topo_graph->add_vertex( $rn );
 983             foreach( @rels ) {
 984                 $rel_containers{$_->id} = $rn;
 985             }
 986         } else {
 987             # Add a new node to mirror the old node.
 988             $rel_containers{$r->id} = $r->id;
 989             $topo_graph->add_vertex( $r->id );
 990         }
 991     }
 992
 993     # Add the edges.
 994     foreach my $r ( $self->readings ) {
 995         foreach my $n ( $self->sequence->successors( $r->id ) ) {
 996                 my( $tfrom, $tto ) = ( $rel_containers{$r->id},
 997                         $rel_containers{$n} );
 998                 $DB::single = 1 unless $tfrom && $tto;
 999             $topo_graph->add_edge( $tfrom, $tto );
1000         }
1001     }
1002
1003     # Now do the rankings, starting with the start node.
1004     my $topo_start = $rel_containers{$self->start->id};
1005     my $node_ranks = { $topo_start => 0 };
1006     my @curr_origin = ( $topo_start );
1007     # A little iterative function.
1008     while( @curr_origin ) {
1009         @curr_origin = _assign_rank( $topo_graph, $node_ranks, @curr_origin );
1010     }
1011     # Transfer our rankings from the topological graph to the real one.
1012     foreach my $r ( $self->readings ) {
1013         if( defined $node_ranks->{$rel_containers{$r->id}} ) {
1014             $r->rank( $node_ranks->{$rel_containers{$r->id}} );
1015         } else {
1016             $DB::single = 1;
1017             die "No rank calculated for node " . $r->id
1018                 . " - do you have a cycle in the graph?";
1019         }
1020     }
1021 }
1022
1023 sub _assign_rank {
1024     my( $graph, $node_ranks, @current_nodes ) = @_;
1025     # Look at each of the children of @current_nodes.  If all the child's
1026     # parents have a rank, assign it the highest rank + 1 and add it to
1027     # @next_nodes.  Otherwise skip it; we will return when the highest-ranked
1028     # parent gets a rank.
1029     my @next_nodes;
1030     foreach my $c ( @current_nodes ) {
1031         warn "Current reading $c has no rank!"
1032             unless exists $node_ranks->{$c};
1033         # print STDERR "Looking at child of node $c, rank "
1034         #     . $node_ranks->{$c} . "\n";
1035         foreach my $child ( $graph->successors( $c ) ) {
1036             next if exists $node_ranks->{$child};
1037             my $highest_rank = -1;
1038             my $skip = 0;
1039             foreach my $parent ( $graph->predecessors( $child ) ) {
1040                 if( exists $node_ranks->{$parent} ) {
1041                     $highest_rank = $node_ranks->{$parent}
1042                         if $highest_rank <= $node_ranks->{$parent};
1043                 } else {
1044                     $skip = 1;
1045                     last;
1046                 }
1047             }
1048             next if $skip;
1049             my $c_rank = $highest_rank + 1;
1050             # print STDERR "Assigning rank $c_rank to node $child \n";
1051             $node_ranks->{$child} = $c_rank;
1052             push( @next_nodes, $child );
1053         }
1054     }
1055     return @next_nodes;
1056 }
1057
1058 # Another method to make up for rough collation methods.  If the same reading
1059 # appears multiple times at the same rank, collapse the nodes.
1060 sub flatten_ranks {
1061     my $self = shift;
1062     my %unique_rank_rdg;
1063     foreach my $rdg ( $self->readings ) {
1064         next unless $rdg->has_rank;
1065         my $key = $rdg->rank . "||" . $rdg->text;
1066         if( exists $unique_rank_rdg{$key} ) {
1067             # Combine!
1068             # print STDERR "Combining readings at same rank: $key\n";
1069             $self->merge_readings( $unique_rank_rdg{$key}, $rdg );
1070         } else {
1071             $unique_rank_rdg{$key} = $rdg;
1072         }
1073     }
1074 }
1075
1076
1077 ## Utility functions
1078
1079 # Return the string that joins together a list of witnesses for
1080 # display on a single path.
1081 sub witnesses_of_label {
1082     my( $self, $label ) = @_;
1083     my $regex = $self->wit_list_separator;
1084     my @answer = split( /\Q$regex\E/, $label );
1085     return @answer;
1086 }
1087
1088 no Moose;
1089 __PACKAGE__->meta->make_immutable;
1090
1091 =head1 BUGS / TODO
1092
1093 =over
1094
1095 =item * Think about making Relationship objects again
1096
1097 =back