lib/Text/Tradition/Stemma.pm

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