lib/Text/Tradition/StemmaUtil.pm

   1 package Text::Tradition::StemmaUtil;
   2
   3 use strict;
   4 use warnings;
   5 use Exporter 'import';
   6 use vars qw/ @EXPORT_OK /;
   7 @EXPORT_OK = qw/ phylip_pars_input /;
   8
   9 sub make_character_matrix {
  10     my( $table ) = @_;
  11     # Push the names of the witnesses to initialize the rows of the matrix.
  12     my @matrix = map { [ _normalize_witname( $_->{'witness'} ) ] }
  13                                 @{$table->{'alignment'}};
  14     foreach my $token_index ( 0 .. $table->{'length'} - 1) {
  15         # First implementation: make dumb alignment table, caring about
  16         # nothing except which reading is in which position.
  17         my @pos_readings = map { $_->{'tokens'}->[$token_index] }
  18                                                         @{$table->{'alignment'}};
  19         my @pos_text = map { $_ ? $_->{'t'} : $_ } @pos_readings;
  20         my @chars = convert_characters( \@pos_text );
  21         foreach my $idx ( 0 .. $#matrix ) {
  22             push( @{$matrix[$idx]}, $chars[$idx] );
  23         }
  24     }
  25     return \@matrix;
  26 }
  27
  28 # Helper function to make the witness name something legal for pars
  29
  30 sub _normalize_witname {
  31     my( $witname ) = @_;
  32     $witname =~ s/\s+/ /g;
  33     $witname =~ s/[\[\]\(\)\:;,]//g;
  34     $witname = substr( $witname, 0, 10 );
  35     return sprintf( "%-10s", $witname );
  36 }
  37
  38 sub convert_characters {
  39     my $row = shift;
  40     # This is a simple algorithm that treats every reading as different.
  41     # Eventually we will want to be able to specify how relationships
  42     # affect the character matrix.
  43     my %unique = ( '__UNDEF__' => 'X',
  44                    '#LACUNA#'  => '?',
  45                  );
  46     my %count;
  47     my $ctr = 0;
  48     foreach my $word ( @$row ) {
  49         if( $word && !exists $unique{$word} ) {
  50             $unique{$word} = chr( 65 + $ctr );
  51             $ctr++;
  52         }
  53         $count{$word}++ if $word;
  54     }
  55     # Try to keep variants under 8 by lacunizing any singletons.
  56     if( scalar( keys %unique ) > 8 ) {
  57                 foreach my $word ( keys %count ) {
  58                         if( $count{$word} == 1 ) {
  59                                 $unique{$word} = '?';
  60                         }
  61                 }
  62     }
  63     my %u = reverse %unique;
  64     if( scalar( keys %u ) > 8 ) {
  65         warn "Have more than 8 variants on this location; phylip will break";
  66     }
  67     my @chars = map { $_ ? $unique{$_} : $unique{'__UNDEF__' } } @$row;
  68     return @chars;
  69 }
  70
  71 sub phylip_pars_input {
  72     my $table = shift;
  73     my $character_matrix = make_character_matrix( $table );
  74     my $input = '';
  75     my $rows = scalar @{$character_matrix};
  76     my $columns = scalar @{$character_matrix->[0]} - 1;
  77     $input .= "\t$rows\t$columns\n";
  78     foreach my $row ( @{$character_matrix} ) {
  79         $input .= join( '', @$row ) . "\n";
  80     }
  81     return $input;
  82 }
  83