analysis/lib/Text/Tradition/Stemma.pm

   1 package Text::Tradition::Stemma;
   2
   3 use Encode qw( decode_utf8 );
   4 use File::Temp;
   5 use Graph;
   6 use Graph::Reader::Dot;
   7 use IPC::Run qw/ run binary /;
   8 use Text::Tradition::Error;
   9 use Moose;
  10
  11 =head1 NAME
  12
  13 Text::Tradition::Stemma - a representation of a I<stemma codicum> for a Text::Tradition
  14
  15 =head1 SYNOPSIS
  16
  17   use Text::Tradition;
  18   my $t = Text::Tradition->new(
  19     'name' => 'this is a text',
  20     'input' => 'TEI',
  21     'file' => '/path/to/tei_parallel_seg_file.xml' );
  22
  23   my $s = $tradition->add_stemma( dotfile => '/path/to/stemma.dot' );
  24
  25 =head1 DESCRIPTION
  26
  27 Text::Tradition is a library for representation and analysis of collated
  28 texts, particularly medieval ones.  The Stemma is a representation of the
  29 copying relationships between the witnesses in a Tradition, modelled with
  30 a connected rooted directed acyclic graph (CRDAG).
  31
  32 =head1 DOT SYNTAX
  33
  34 The easiest way to define a stemma is to use a special form of the 'dot'
  35 syntax of GraphViz.
  36
  37 Each stemma opens with the line
  38
  39  digraph Stemma {
  40
  41 and continues with a list of all manuscript witnesses in the stemma, whether
  42 extant witnesses or missing archetypes or hyparchetypes.  Each of these is
  43 listed by its sigil on its own line, e.g.:
  44
  45   alpha [ class=hypothetical ]
  46   1 [ class=hypothetical,label=* ]
  47   Ms4 [ class=extant ]
  48
  49 Extant witnesses are listed with class=extant; missing or postulated witnesses
  50 are listed with class=hypothetical.  Anonymous hyparchetypes must be given a
  51 unique name or number, but can be represented as anonymous with the addition
  52 of 'label=*' to their lines.  Greek letters or other special characters may be
  53 used as names, but they must always be wrapped in double quotes.
  54
  55 Links between manuscripts are then listed with arrow notation, as below. These
  56 lines show the direction of copying, one step at a time, for the entire stemma.
  57
  58   alpha -> 1
  59   1 -> Ms4
  60
  61 The final line in the definition should be the closing brace:
  62
  63  }
  64
  65 Thus for a set of extant manuscripts A, B, and C, where A and B were copied
  66 from the archetype O and C was copied from B, the definition would be:
  67
  68  digraph Stemma {
  69      O [ class=hypothetical]
  70      A [ class=extant ]
  71      B [ class=extant ]
  72      C [ class=extant ]
  73      O -> A
  74      O -> B
  75      B -> C
  76  }
  77
  78 =head1 CONSTRUCTOR
  79
  80 =head2 new
  81
  82 The constructor.  This should generally be called from Text::Tradition, but
  83 if called directly it takes the following options:
  84
  85 =over
  86
  87 =item * dot - A filehandle open to a DOT representation of the stemma graph.
  88
  89 =item * graph - If no DOT specification is given, you can pass a Graph object
  90 instead.  The vertices of the graph should have an attribute 'class' set to
  91 either of the values 'extant' or 'hypothetical'.
  92
  93 =item * is_undirected - If the graph specification (or graph object) is for an
  94 undirected graph (e.g. a phylogenetic tree), this should be set.
  95
  96 =back
  97
  98 =begin testing
  99
 100 use TryCatch;
 101
 102 use_ok( 'Text::Tradition::Stemma' );
 103
 104 # Try to create a bad graph
 105 TODO: {
 106         local $TODO = "cannot use stdout redirection trick with FastCGI";
 107         my $baddotfh;
 108         open( $baddotfh, 't/data/besoin_bad.dot' ) or die "Could not open test dotfile";
 109         try {
 110                 my $stemma = Text::Tradition::Stemma->new( dot => $baddotfh );
 111                 ok( 0, "Created broken stemma from dotfile with syntax error" );
 112         } catch( Text::Tradition::Error $e ) {
 113                 like( $e->message, qr/^Error trying to parse/, "Syntax error in dot threw exception" );
 114         }
 115 }
 116
 117 # Create a good graph
 118 my $dotfh;
 119 open( $dotfh, 't/data/florilegium.dot' ) or die "Could not open test dotfile";
 120 binmode( $dotfh, ':utf8' );
 121 my $stemma = Text::Tradition::Stemma->new( dot => $dotfh );
 122 is( ref( $stemma ), 'Text::Tradition::Stemma', "Created stemma from good dotfile" );
 123 is( scalar $stemma->witnesses, 13, "Found correct number of extant witnesses" );
 124 is( scalar $stemma->hypotheticals, 8, "Found correct number of extant hypotheticals" );
 125 my $found_unicode_sigil;
 126 foreach my $h ( $stemma->hypotheticals ) {
 127         $found_unicode_sigil = 1 if $h eq "\x{3b1}";
 128 }
 129 ok( $found_unicode_sigil, "Found a correctly encoded Unicode sigil" );
 130
 131 # TODO Create stemma from graph, create stemma from undirected graph,
 132 # create stemma from incompletely-specified graph
 133
 134 =end testing
 135
 136 =cut
 137
 138 has collation => (
 139     is => 'ro',
 140     isa => 'Text::Tradition::Collation',
 141     clearer => 'clear_collation', # interim measure to remove refs in DB
 142     weak_ref => 1,
 143     );
 144
 145 has graph => (
 146     is => 'rw',
 147     isa => 'Graph',
 148     predicate => 'has_graph',
 149     );
 150
 151 has is_undirected => (
 152         is => 'ro',
 153         isa => 'Bool',
 154         default => undef,
 155         writer => 'set_undirected',
 156         );
 157
 158 sub BUILD {
 159     my( $self, $args ) = @_;
 160     # If we have been handed a dotfile, initialize it into a graph.
 161     if( exists $args->{'dot'} ) {
 162         $self->_graph_from_dot( $args->{'dot'} );
 163     } else {
 164         }
 165 }
 166
 167 before 'graph' => sub {
 168         my $self = shift;
 169         if( @_ ) {
 170                 # Make sure all unclassed graph nodes are marked extant.
 171                 my $g = $_[0];
 172                 throw( "Cannot set graph to a non-Graph object" )
 173                         unless ref( $g ) eq 'Graph';
 174                 foreach my $v ( $g->vertices ) {
 175                         unless( $g->has_vertex_attribute( $v, 'class' ) ) {
 176                                 $g->set_vertex_attribute( $v, 'class', 'extant' );
 177                         }
 178                 }
 179                 $self->set_undirected( $g->is_undirected );
 180         }
 181 };
 182
 183 sub _graph_from_dot {
 184         my( $self, $dotfh ) = @_;
 185         my $reader = Graph::Reader::Dot->new();
 186         # Redirect STDOUT in order to trap any error messages - syntax errors
 187         # are evidently not fatal.
 188         # TODO This breaks under FastCGI/Apache; reconsider.
 189         my $reader_out;
 190         #my $saved_stderr;
 191         #open $saved_stderr, ">&STDOUT";
 192         #close STDOUT;
 193         #open STDOUT, ">", \$reader_out;
 194         my $graph = $reader->read_graph( $dotfh );
 195         #close STDOUT;
 196         #open STDOUT, ">", \$saved_stderr;
 197         if( $reader_out && $reader_out =~ /error/s ) {
 198                 throw( "Error trying to parse dot: $reader_out" );
 199         } elsif( !$graph ) {
 200                 throw( "Failed to create graph from dot" );
 201         }
 202         $self->graph( $graph );
 203 }
 204
 205 =head1 METHODS
 206
 207 =head2 as_dot( \%options )
 208
 209 Returns a normal dot representation of the stemma layout, suitable for rendering
 210 with GraphViz.  Options include:
 211
 212 =over
 213
 214 =item * graph - A hashref of global graph options.
 215
 216 =item * node - A hashref of global node options.
 217
 218 =item * edge - A hashref of global edge options.
 219
 220 =back
 221
 222 See the GraphViz documentation for the list of available options.
 223
 224 =cut
 225
 226 sub as_dot {
 227     my( $self, $opts ) = @_;
 228
 229         ## See if we are including any a.c. witnesses in this graph.
 230         my $graph = $self->graph;
 231         if( exists $opts->{'layerwits'} ) {
 232                 my $extant = {};
 233                 map { $extant->{$_} = 1 } $self->witnesses;
 234                 $graph = $self->situation_graph( $extant, $opts->{'layerwits'} );
 235         }
 236
 237     # Get default and specified options
 238     my %graphopts = (
 239         # 'ratio' => 1,
 240         'bgcolor' => 'transparent',
 241     );
 242     my %nodeopts = (
 243                 'fontsize' => 11,
 244                 'style' => 'filled',
 245                 'fillcolor' => 'white',
 246                 'color' => 'white',
 247                 'shape' => 'ellipse',   # Shape for the extant nodes
 248         );
 249         my %edgeopts = (
 250                 'arrowhead' => 'none',
 251         );
 252         @graphopts{ keys %{$opts->{'graph'}} } = values %{$opts->{'graph'}}
 253                 if $opts->{'graph'};
 254         @nodeopts{ keys %{$opts->{'node'}} } = values %{$opts->{'node'}}
 255                 if $opts->{'node'};
 256         @edgeopts{ keys %{$opts->{'edge'}} } = values %{$opts->{'edge'}}
 257                 if $opts->{'edge'};
 258
 259         my $gdecl = $graph->is_directed ? 'digraph' : 'graph';
 260         my @dotlines;
 261         push( @dotlines, "$gdecl stemma {" );
 262         ## Print out the global attributes
 263         push( @dotlines, _make_dotline( 'graph', %graphopts ) ) if keys %graphopts;
 264         push( @dotlines, _make_dotline( 'edge', %edgeopts ) ) if keys %edgeopts;
 265         push( @dotlines, _make_dotline( 'node', %nodeopts ) ) if keys %nodeopts;
 266
 267         # Add each of the nodes.
 268     foreach my $n ( $graph->vertices ) {
 269         if( $graph->has_vertex_attribute( $n, 'label' ) ) {
 270                 my $ltext = $graph->get_vertex_attribute( $n, 'label' );
 271                 push( @dotlines, _make_dotline( $n, 'label' => $ltext ) );
 272         } else {
 273                 # Use the default display settings.
 274                 $n = _dotquote( $n );
 275             push( @dotlines, "  $n;" );
 276         }
 277     }
 278     # Add each of our edges.
 279     foreach my $e ( $graph->edges ) {
 280         my( $from, $to ) = map { _dotquote( $_ ) } @$e;
 281         my $connector = $graph->is_directed ? '->' : '--';
 282         push( @dotlines, "  $from $connector $to;" );
 283     }
 284     push( @dotlines, '}' );
 285
 286     return join( "\n", @dotlines );
 287 }
 288
 289 =head2 alter_graph( $dotstring )
 290
 291 Alters the graph of this stemma according to the definition specified
 292 in $dotstring.
 293
 294 =cut
 295
 296 sub alter_graph {
 297         my( $self, $dotstring ) = @_;
 298         my $dotfh;
 299         open $dotfh, '<', \$dotstring;
 300         binmode $dotfh, ':utf8';
 301         $self->_graph_from_dot( $dotfh );
 302 }
 303
 304 =head2 editable( $opts )
 305
 306 =head2 editable_graph( $graph, $opts )
 307
 308 Returns a version of the graph rendered in our definition format.  The
 309 output separates statements with a newline; set $opts->{'linesep'} to the
 310 empty string or to a space if the result is to be sent via JSON.
 311
 312 If a situational version of the stemma is required, the arguments for
 313 situation_graph should be passed via $opts->{'extant'} and $opts->{'layerwits'}.
 314
 315 =cut
 316
 317 sub editable {
 318         my( $self, $opts ) = @_;
 319         my $graph = $self->graph;
 320         ## See if we need an editable version of a situational graph.
 321         if( exists $opts->{'layerwits'} || exists $opts->{'extant'} ) {
 322                 my $extant = delete $opts->{'extant'} || {};
 323                 my $layerwits = delete $opts->{'layerwits'} || [];
 324                 $graph = $self->situation_graph( $extant, $layerwits );
 325         }
 326         return editable_graph( $graph, $opts );
 327 }
 328
 329 sub editable_graph {
 330         my( $graph, $opts ) = @_;
 331
 332         # Create the graph
 333         my $join = ( $opts && exists $opts->{'linesep'} ) ? $opts->{'linesep'} : "\n";
 334         my $gdecl = $graph->is_undirected ? 'graph' : 'digraph';
 335         my @dotlines;
 336         push( @dotlines, "$gdecl stemma {" );
 337         my @real; # A cheap sort
 338     foreach my $n ( sort $graph->vertices ) {
 339         my $c = $graph->get_vertex_attribute( $n, 'class' );
 340         $c = 'extant' unless $c;
 341         if( $c eq 'extant' ) {
 342                 push( @real, $n );
 343         } else {
 344                         push( @dotlines, _make_dotline( $n, 'class' => $c ) );
 345                 }
 346     }
 347         # Now do the real ones
 348         foreach my $n ( @real ) {
 349                 push( @dotlines, _make_dotline( $n, 'class' => 'extant' ) );
 350         }
 351         foreach my $e ( sort _by_vertex $graph->edges ) {
 352                 my( $from, $to ) = map { _dotquote( $_ ) } @$e;
 353                 my $conn = $graph->is_undirected ? '--' : '->';
 354                 push( @dotlines, "  $from $conn $to;" );
 355         }
 356     push( @dotlines, '}' );
 357     return join( $join, @dotlines );
 358 }
 359
 360 sub _make_dotline {
 361         my( $obj, %attr ) = @_;
 362         my @pairs;
 363         foreach my $k ( keys %attr ) {
 364                 my $v = _dotquote( $attr{$k} );
 365                 push( @pairs, "$k=$v" );
 366         }
 367         return sprintf( "  %s [ %s ];", _dotquote( $obj ), join( ', ', @pairs ) );
 368 }
 369
 370 sub _dotquote {
 371         my( $str ) = @_;
 372         return $str if $str =~ /^[A-Za-z0-9]+$/;
 373         $str =~ s/\"/\\\"/g;
 374         $str = '"' . $str . '"';
 375         return $str;
 376 }
 377
 378 sub _by_vertex {
 379         return $a->[0].$a->[1] cmp $b->[0].$b->[1];
 380 }
 381
 382 =head2 situation_graph( $extant, $layered )
 383
 384 Returns a graph which is the original stemma graph with all witnesses not
 385 in the %$extant hash marked as hypothetical, and witness layers added to
 386 the graph according to the list in @$layered.  A layered (a.c.) witness is
 387 added as a parent of its main version, and additionally shares all other
 388 parents and children with that version.
 389
 390 =cut
 391
 392 sub situation_graph {
 393         my( $self, $extant, $layerwits, $layerlabel ) = @_;
 394
 395         my $graph = $self->graph->copy;
 396         foreach my $vertex ( $graph->vertices ) {
 397                 # Set as extant any vertex that is extant in the stemma AND
 398                 # exists in the $extant hash.
 399                 my $class = 'hypothetical';
 400                 $class = 'extant' if exists $extant->{$vertex} && $extant->{$vertex} &&
 401                         $self->graph->get_vertex_attribute( $vertex, 'class' ) ne 'hypothetical';
 402                 $graph->set_vertex_attribute( $vertex, 'class', $class );
 403         }
 404
 405         # For each 'layered' witness in the layerwits array, add it to the graph
 406         # as an ancestor of the 'main' witness, and otherwise with the same parent/
 407         # child links as its main analogue.
 408         # TOOD Handle case where B is copied from A but corrected from C
 409         $layerlabel = ' (a.c.)' unless $layerlabel;
 410         foreach my $lw ( @$layerwits ) {
 411                 # Add the layered witness and set it with the same attributes as
 412                 # its 'main' analogue
 413                 throw( "Cannot add a layer to a hypothetical witness $lw" )
 414                         unless $graph->get_vertex_attribute( $lw, 'class' ) eq 'extant';
 415                 my $lwac = $lw . $layerlabel;
 416                 $graph->add_vertex( $lwac );
 417                 $graph->set_vertex_attributes( $lwac,
 418                         $graph->get_vertex_attributes( $lw ) );
 419
 420                 # Set it as ancestor to the main witness
 421                 $graph->add_edge( $lwac, $lw );
 422
 423                 # Give it the same ancestors and descendants as the main witness has,
 424                 # bearing in mind that those ancestors and descendants might also just
 425                 # have had a layered witness defined.
 426                 foreach my $v ( $graph->predecessors( $lw ) ) {
 427                         next if $v eq $lwac; # Don't add a loop
 428                         $graph->add_edge( $v, $lwac );
 429                         $graph->add_edge( $v.$layerlabel, $lwac )
 430                                 if $graph->has_vertex( $v.$layerlabel );
 431                 }
 432                 foreach my $v ( $graph->successors( $lw ) ) {
 433                         next if $v eq $lwac; # but this shouldn't occur
 434                         $graph->add_edge( $lwac, $v );
 435                         $graph->add_edge( $lwac, $v.$layerlabel )
 436                                 if $graph->has_vertex( $v.$layerlabel );
 437                 }
 438         }
 439         return $graph;
 440 }
 441
 442 =head2 as_svg
 443
 444 Returns an SVG representation of the graph, calling as_dot first.
 445
 446 =cut
 447
 448 sub as_svg {
 449     my( $self, $opts ) = @_;
 450     my $dot = $self->as_dot( $opts );
 451     my @cmd = ( '-Tsvg' );
 452     unshift( @cmd, $self->is_undirected ? 'neato' : 'dot' );
 453     my $svg;
 454     my $dotfile = File::Temp->new();
 455     binmode $dotfile, ':utf8';
 456     print $dotfile $dot;
 457     close $dotfile;
 458     push( @cmd, $dotfile->filename );
 459     run( \@cmd, ">", binary(), \$svg );
 460     return decode_utf8( $svg );
 461 }
 462
 463 =head2 witnesses
 464
 465 Returns a list of the extant witnesses represented in the stemma.
 466
 467 =cut
 468
 469 sub witnesses {
 470     my $self = shift;
 471     my @wits = grep { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'extant' }
 472         $self->graph->vertices;
 473     return @wits;
 474 }
 475
 476 =head2 hypotheticals
 477
 478 Returns a list of the hypothetical witnesses represented in the stemma.
 479
 480 =cut
 481
 482 sub hypotheticals {
 483     my $self = shift;
 484     my @wits = grep
 485         { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'hypothetical' }
 486         $self->graph->vertices;
 487     return @wits;
 488 }
 489
 490 =head2 root_graph( $root_vertex )
 491
 492 If the stemma graph is undirected, make it directed with $root_vertex at the root.
 493 If it is directed, re-root it.
 494
 495 =cut
 496
 497 sub root_graph {
 498         my( $self, $rootvertex ) = @_;
 499         my $graph;
 500         if( $self->is_undirected ) {
 501                 $graph = $self->graph;
 502         } else {
 503                 # Make an undirected version of this graph.
 504                 $graph = $self->graph->undirected_copy();
 505         }
 506         my $rooted = Graph->new();
 507         $rooted->add_vertex( $rootvertex );
 508         my @next = ( $rootvertex );
 509         while( @next ) {
 510                 my @children;
 511                 foreach my $v ( @next ) {
 512                         # Place its not-placed neighbors (ergo children) in the tree
 513                         # and connect them
 514                         foreach my $n ( grep { !$rooted->has_vertex( $_ ) }
 515                                 $graph->neighbors( $v ) ) {
 516                                 $rooted->add_vertex( $n );
 517                                 $rooted->add_edge( $v, $n );
 518                                 push( @children, $n );
 519                         }
 520                 }
 521                 @next = @children;
 522         }
 523         # Set the vertex classes
 524         map { $rooted->set_vertex_attribute( $_, 'class', 'hypothetical' ) }
 525                 $self->graph->hypotheticals;
 526         map { $rooted->set_vertex_class( $_, 'class', 'extant' ) }
 527                 $self->graph->witnesses;
 528         return $rooted;
 529 }
 530
 531
 532 sub throw {
 533         Text::Tradition::Error->throw(
 534                 'ident' => 'Stemma error',
 535                 'message' => $_[0],
 536                 );
 537 }
 538
 539
 540 no Moose;
 541 __PACKAGE__->meta->make_immutable;
 542
 543 1;
 544
 545 =head1 LICENSE
 546
 547 This package is free software and is provided "as is" without express
 548 or implied warranty.  You can redistribute it and/or modify it under
 549 the same terms as Perl itself.
 550
 551 =head1 AUTHOR
 552
 553 Tara L Andrews E<lt>aurum@cpan.orgE<gt>