sub make_character_matrix {
my $self = shift;
unless( $self->collation->linear ) {
- warn "Need a linear graph in order to make an alignment table";
- return;
+ warn "Need a linear graph in order to make an alignment table";
+ return;
}
- my @all_pos = sort { Text::Tradition::Collation::Position::str_cmp( $a, $b ) }
- $self->collation->possible_positions;
- my $table = [];
- my $characters = {};
- map { $characters->{$_} = {} } @all_pos;
- foreach my $wit ( @{$self->collation->tradition->witnesses} ) {
- # First implementation: make dumb alignment table, caring about
- # nothing except which reading is in which position.
- push( @$table, [ $wit->sigil, make_witness_row( $characters, $wit->path,
- \@all_pos ) ] );
- if( $wit->has_ante_corr ) {
- push( @$table, [ $wit->sigil . "_ac",
- make_witness_row( $characters, $wit->uncorrected_path,
- \@all_pos ) ] );
- }
+ my $table = $self->collation->make_alignment_table;
+ # Push the names of the witnesses to initialize the rows of the matrix.
+ my @matrix = map { [ $self->_normalize_ac( $_ ) ] } @{$table->[0]};
+ $DB::single = 1;
+ foreach my $token_index ( 1 .. $#{$table} ) {
+ # First implementation: make dumb alignment table, caring about
+ # nothing except which reading is in which position.
+ my @chars = convert_characters( $table->[$token_index] );
+ foreach my $idx ( 0 .. $#matrix ) {
+ push( @{$matrix[$idx]}, $chars[$idx] );
+ }
}
- $self->_save_character_matrix( $table );
-}
+ $self->_save_character_matrix( \@matrix );
+}
-sub make_witness_row {
- my( $characters, $path, $positions ) = @_;
- my @row;
- my $pathdrift = 0;
- foreach my $i( 0 .. $#{$positions} ) {
- if( $path->[$i-$pathdrift]->position->minref eq $positions->[$i] ) {
- push( @row, get_character( $path->[$i-$pathdrift], $characters ) );
- } else {
- push( @row, 'X' );
- $pathdrift++;
- }
- $i++;
+sub _normalize_ac {
+ my( $self, $witname ) = @_;
+ my $ac = $self->collation->ac_label;
+ if( $witname =~ /(.*)\Q$ac\E$/ ) {
+ $witname = $1 . '_ac';
}
- return @row;
+ return sprintf( "%-10s", $witname );
}
-
-sub get_character {
- my( $reading, $characters ) = @_;
- my $this_pos = $characters->{$reading->position->minref};
+sub convert_characters {
+ my $row = shift;
# This is a simple algorithm that treats every reading as different.
# Eventually we will want to be able to specify how relationships
# affect the character matrix.
- my $text = $reading->text;
- unless( exists $this_pos->{$text} ) {
- # We need to find what the next character is here, and record it.
- my @all_chr = sort { $a <=> $b } values( %$this_pos );
- if( @all_chr == 8 ) {
- warn "Already have eight variants at position "
- . $reading->position->minref . "; not adding " . $reading->text;
- return '?';
- }
- $this_pos->{$text} = scalar @all_chr;
+ my %unique = ( '__UNDEF__' => 'X',
+ '#LACUNA#' => '?',
+ );
+ my $ctr = 0;
+ foreach my $word ( @$row ) {
+ if( $word && !exists $unique{$word} ) {
+ $unique{$word} = chr( 65 + $ctr );
+ $ctr++;
+ }
}
- return $this_pos->{$text};
+ if( scalar( keys %unique ) > 8 ) {
+ warn "Have more than 8 variants on this location; pars will break";
+ }
+ my @chars = map { $_ ? $unique{$_} : $unique{'__UNDEF__' } } @$row;
+ return @chars;
}
-sub run_pars {
+sub pars_input {
my $self = shift;
$self->make_character_matrix unless $self->has_character_matrix;
+ my $matrix = '';
+ my $rows = scalar @{$self->character_matrix};
+ my $columns = scalar @{$self->character_matrix->[0]} - 1;
+ $matrix .= "\t$rows\t$columns\n";
+ foreach my $row ( @{$self->character_matrix} ) {
+ $matrix .= join( '', @$row ) . "\n";
+ }
+ return $matrix;
+}
+
+sub run_pars {
+ my $self = shift;
# Set up a temporary directory for all the default Phylip files.
my $phylip_dir = File::Temp->newdir();
-
+ print STDERR $phylip_dir . "\n";
+ # $phylip_dir->unlink_on_destroy(0);
# We need an infile, and we need a command input file.
- $DB::single = 1;
open( MATRIX, ">$phylip_dir/infile" ) or die "Could not write $phylip_dir/infile";
- my $rows = scalar @{$self->character_matrix};
- my $columns = scalar @{$self->character_matrix->[0]} - 1;
- print MATRIX "\t$rows\t$columns\n";
- foreach my $row ( @{$self->character_matrix} ) {
- my $wit = shift @$row;
- my $chars = join( '', @$row );
- print MATRIX sprintf( "%-10s%s\n", $wit, $chars );
- }
+ print MATRIX $self->pars_input();
close MATRIX;
open( CMD, ">$phylip_dir/cmdfile" ) or die "Could not write $phylip_dir/cmdfile";
my $PHYLIP_PATH = '/Users/tla/Projects/phylip-3.69/exe';
my $program = "pars";
if( $^O eq 'darwin' ) {
- $program = "$PHYLIP_PATH/$program.app/Contents/MacOS/$program";
+ $program = "$PHYLIP_PATH/$program.app/Contents/MacOS/$program";
} else {
- $program = "$PHYLIP_PATH/$program";
+ $program = "$PHYLIP_PATH/$program";
}
{
- # We need to run it in our temporary directory where we have created
- # all the expected files.
- local $CWD = $phylip_dir;
- my @cmd = ( $program );
- run \@cmd, '<', 'cmdfile', '>', '/dev/null';
+ # We need to run it in our temporary directory where we have created
+ # all the expected files.
+ local $CWD = $phylip_dir;
+ my @cmd = ( $program );
+ run \@cmd, '<', 'cmdfile', '>', '/dev/null';
}
# Now our output should be in 'outfile' and our tree in 'outtree',
# both in the temp directory.
my @outtree;
if( -f "$phylip_dir/outtree" ) {
- open( TREE, "$phylip_dir/outtree" ) or die "Could not open outtree for read";
- @outtree = <TREE>;
- close TREE;
+ open( TREE, "$phylip_dir/outtree" ) or die "Could not open outtree for read";
+ @outtree = <TREE>;
+ close TREE;
}
return( 1, join( '', @outtree ) ) if @outtree;
my @error;
- if( -f "$phylip_dir/output" ) {
- open( OUTPUT, "$phylip_dir/output" ) or die "Could not open output for read";
- @error = <OUTPUT>;
- close OUTPUT;
+ if( -f "$phylip_dir/outfile" ) {
+ open( OUTPUT, "$phylip_dir/outfile" ) or die "Could not open output for read";
+ @error = <OUTPUT>;
+ close OUTPUT;
} else {
- push( @error, "Neither outtree nor output file was produced!" );
+ push( @error, "Neither outtree nor output file was produced!" );
}
return( undef, join( '', @error ) );
}
projects / scpubgit/stemmatology.git / blobdiff