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 Collation is the central feature of
  31 a Tradition, where the text, its sequence of readings, and its relationships
  32 between readings are actually kept.
  33
  34 =head1 DOT SYNTAX
  35
  36 The easiest way to define a stemma (which is a directed acyclic graph, denoting
  37 the scholar's hypothesis concerning which text(s) were copied from which other(s))
  38 is to use a special form of the 'dot' syntax of GraphViz.
  39
  40 Each stemma opens with the line
  41
  42  digraph Stemma {
  43
  44 and continues with a list of all manuscript witnesses in the stemma, whether
  45 extant witnesses or missing archetypes or hyparchetypes.  Each of these is
  46 listed by its sigil on its own line, e.g.:
  47
  48   alpha [ class=hypothetical ]
  49   1 [ class=hypothetical,label=* ]
  50   Ms4 [ class=extant ]
  51
  52 Extant witnesses are listed with class=extant; missing or postulated witnesses
  53 are listed with class=hypothetical.  Anonymous hyparchetypes must be given a
  54 unique name or number, but can be represented as anonymous with the addition
  55 of 'label=*' to their lines.  Greek letters or other special characters may be
  56 used as names, but they must always be wrapped in double quotes.
  57
  58 Links between manuscripts are then listed with arrow notation, as below. These
  59 lines show the direction of copying, one step at a time, for the entire stemma.
  60
  61   alpha -> 1
  62   1 -> Ms4
  63
  64 The final line in the definition should be the closing brace:
  65
  66  }
  67
  68 Thus for a set of extant manuscripts A, B, and C, where A and B were copied
  69 from the archetype O and C was copied from B, the definition would be:
  70
  71  digraph Stemma {
  72      O [ class=hypothetical]
  73      A [ class=extant ]
  74      B [ class=extant ]
  75      C [ class=extant ]
  76      O -> A
  77      O -> B
  78      B -> C
  79  }
  80
  81 =head1 CONSTRUCTOR
  82
  83 =head2 new
  84
  85 The constructor.  This should generally be called from Text::Tradition, but
  86 if called directly it takes the following options:
  87
  88 =over
  89
  90 =item * collation - The collation with which the stemma is associated.
  91
  92 =item * dot - A filehandle open to a DOT representation of the stemma graph.
  93
  94 =back
  95
  96 =cut
  97
  98 has collation => (
  99     is => 'ro',
 100     isa => 'Text::Tradition::Collation',
 101     required => 1,
 102     weak_ref => 1,
 103     );
 104
 105 has graph => (
 106     is => 'rw',
 107     isa => 'Graph',
 108     predicate => 'has_graph',
 109     );
 110
 111 has distance_trees => (
 112     is => 'ro',
 113     isa => 'ArrayRef[Graph]',
 114     writer => '_save_distance_trees',
 115     predicate => 'has_distance_trees',
 116     );
 117
 118 has distance_program => (
 119         is => 'rw',
 120         isa => 'Str',
 121         default => '',
 122         );
 123
 124 sub BUILD {
 125     my( $self, $args ) = @_;
 126     # If we have been handed a dotfile, initialize it into a graph.
 127     if( exists $args->{'dot'} ) {
 128         $self->_graph_from_dot( $args->{'dot'} );
 129     }
 130 }
 131
 132 sub _graph_from_dot {
 133         my( $self, $dotfh ) = @_;
 134         my $reader = Graph::Reader::Dot->new();
 135         my $graph = $reader->read_graph( $dotfh );
 136         if( $graph ) {
 137                 $self->graph( $graph );
 138                 # Go through the nodes and set any non-hypothetical node to extant.
 139                 foreach my $v ( $self->graph->vertices ) {
 140                         $self->graph->set_vertex_attribute( $v, 'class', 'extant' )
 141                                 unless $self->graph->has_vertex_attribute( $v, 'class' );
 142                 }
 143         } else {
 144                 throw( "Failed to parse dot in $dotfh" );
 145         }
 146 }
 147
 148 =head1 METHODS
 149
 150 =head2 as_dot( \%options )
 151
 152 Returns a normal dot representation of the stemma layout, suitable for rendering
 153 with GraphViz.  Options include:
 154
 155 =over
 156
 157 =item * graph - A hashref of global graph options.
 158
 159 =item * node - A hashref of global node options.
 160
 161 =item * edge - A hashref of global edge options.
 162
 163 =back
 164
 165 See the GraphViz documentation for the list of available options.
 166
 167 =cut
 168
 169 sub as_dot {
 170     my( $self, $opts ) = @_;
 171
 172     # Get default and specified options
 173     my %graphopts = (
 174         # 'ratio' => 1,
 175     );
 176     my %nodeopts = (
 177                 'fontsize' => 11,
 178                 'style' => 'filled',
 179                 'fillcolor' => 'white',
 180                 'color' => 'white',
 181                 'shape' => 'ellipse',   # Shape for the extant nodes
 182         );
 183         my %edgeopts = (
 184                 'arrowhead' => 'none',
 185         );
 186         @graphopts{ keys %{$opts->{'graph'}} } = values %{$opts->{'graph'}}
 187                 if $opts->{'graph'};
 188         @nodeopts{ keys %{$opts->{'node'}} } = values %{$opts->{'node'}}
 189                 if $opts->{'node'};
 190         @edgeopts{ keys %{$opts->{'edge'}} } = values %{$opts->{'edge'}}
 191                 if $opts->{'edge'};
 192
 193         my @dotlines;
 194         push( @dotlines, 'digraph stemma {' );
 195         ## Print out the global attributes
 196         push( @dotlines, _make_dotline( 'graph', %graphopts ) ) if keys %graphopts;
 197         push( @dotlines, _make_dotline( 'edge', %edgeopts ) ) if keys %edgeopts;
 198         push( @dotlines, _make_dotline( 'node', %nodeopts ) ) if keys %nodeopts;
 199
 200         # Add each of the nodes.
 201     foreach my $n ( $self->graph->vertices ) {
 202         if( $self->graph->has_vertex_attribute( $n, 'label' ) ) {
 203                 my $ltext = $self->graph->get_vertex_attribute( $n, 'label' );
 204                 push( @dotlines, _make_dotline( $n, 'label' => $ltext ) );
 205         } else {
 206                 # Use the default display settings.
 207             push( @dotlines, "  $n;" );
 208         }
 209     }
 210     # Add each of our edges.
 211     foreach my $e ( $self->graph->edges ) {
 212         my( $from, $to ) = @$e;
 213         push( @dotlines, "  $from -> $to;" );
 214     }
 215     push( @dotlines, '}' );
 216
 217     return join( "\n", @dotlines );
 218 }
 219
 220 =head2 editable
 221
 222 Returns a version of the graph rendered in our definition format.
 223
 224 =cut
 225
 226 sub editable {
 227         my $self = shift;
 228         my @dotlines;
 229         push( @dotlines, 'digraph stemma {' );
 230         my @real; # A cheap sort
 231     foreach my $n ( sort $self->graph->vertices ) {
 232         my $c = $self->graph->get_vertex_attribute( $n, 'class' );
 233         $c = 'extant' unless $c;
 234         if( $c eq 'extant' ) {
 235                 push( @real, $n );
 236         } else {
 237                         push( @dotlines, _make_dotline( $n, 'class' => $c ) );
 238                 }
 239     }
 240         # Now do the real ones
 241         foreach my $n ( @real ) {
 242                 push( @dotlines, _make_dotline( $n, 'class' => 'extant' ) );
 243         }
 244         foreach my $e ( sort _by_vertex $self->graph->edges ) {
 245                 my( $from, $to ) = @$e;
 246                 push( @dotlines, "  $from -> $to;" );
 247         }
 248     push( @dotlines, '}' );
 249     return join( "\n", @dotlines );
 250 }
 251
 252 sub _make_dotline {
 253         my( $obj, %attr ) = @_;
 254         my @pairs;
 255         foreach my $k ( keys %attr ) {
 256                 my $v = $attr{$k};
 257                 $v =~ s/\"/\\\"/g;
 258                 push( @pairs, "$k=\"$v\"" );
 259         }
 260         return sprintf( "  %s [ %s ];", $obj, join( ', ', @pairs ) );
 261 }
 262
 263 sub _by_vertex {
 264         return $a->[0].$a->[1] cmp $b->[0].$b->[1];
 265 }
 266
 267 =head2 as_svg
 268
 269 Returns an SVG representation of the graph, calling as_dot first.
 270
 271 =cut
 272
 273 sub as_svg {
 274     my( $self, $opts ) = @_;
 275     my $dot = $self->as_dot( $opts );
 276     my @cmd = qw/dot -Tsvg/;
 277     my( $svg, $err );
 278     my $dotfile = File::Temp->new();
 279     ## TODO REMOVE
 280     # $dotfile->unlink_on_destroy(0);
 281     binmode $dotfile, ':utf8';
 282     print $dotfile $dot;
 283     push( @cmd, $dotfile->filename );
 284     run( \@cmd, ">", binary(), \$svg );
 285     $svg = decode_utf8( $svg );
 286     return $svg;
 287 }
 288
 289 =head2 witnesses
 290
 291 Returns a list of the extant witnesses represented in the stemma.
 292
 293 =cut
 294
 295 sub witnesses {
 296     my $self = shift;
 297     my @wits = grep { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'extant' }
 298         $self->graph->vertices;
 299     return @wits;
 300 }
 301
 302 =head2 distance_trees( program => $program )
 303
 304 Returns a set of undirected graphs, which are the result of running a distance
 305 tree calculation program on the collation.  Currently the only supported
 306 program is phylip_pars.
 307
 308 =cut
 309
 310 #### Methods for calculating phylogenetic trees ####
 311
 312 before 'distance_trees' => sub {
 313     my $self = shift;
 314     my %args = (
 315         'program' => 'phylip_pars',
 316         @_ );
 317     # TODO allow specification of method for calculating distance tree
 318     if( !$self->has_distance_trees
 319         || $args{'program'} ne $self->distance_program ) {
 320         # We need to make a tree before we can return it.
 321         my $dsub = 'run_' . $args{'program'};
 322         my $result = $self->$dsub(); # this might throw an error - catch it?
 323                 # Save the resulting trees
 324                 my $trees = parse_newick( $result );
 325                 $self->_save_distance_trees( $trees );
 326                 $self->distance_program( $args{'program'} );
 327     }
 328 };
 329
 330 =head2 run_phylip_pars
 331
 332 Runs Phylip Pars on the collation, returning the results in Newick format.
 333 Used for the distance_trees calculation.
 334
 335 =cut
 336
 337 sub run_phylip_pars {
 338         my $self = shift;
 339         my $cdata = character_input( $self->collation->make_alignment_table() );
 340         return phylip_pars( $cdata );
 341 }
 342
 343 sub throw {
 344         Text::Tradition::Error->throw(
 345                 'ident' => 'Stemma error',
 346                 'message' => $_[0],
 347                 );
 348 }
 349
 350
 351 no Moose;
 352 __PACKAGE__->meta->make_immutable;
 353
 354 1;
 355
 356 =head1 LICENSE
 357
 358 This package is free software and is provided "as is" without express
 359 or implied warranty.  You can redistribute it and/or modify it under
 360 the same terms as Perl itself.
 361
 362 =head1 AUTHOR
 363
 364 Tara L Andrews E<lt>aurum@cpan.orgE<gt>