这两个脚本是相关连的。可以执行脚本1后再执行脚本2。
第三个脚本将脚本2生成的某文件变为对称矩阵。
文件名神马的当然得改了，程序友好度不佳
脚本1：
dist_ident_1.pl
#!perl -w# 这是以前写的代码，tab不改空格了……#貌似运行成功#分开Nei 1972或1978的数据的 genetic distance 与 genetic identity 表#数据是Popgene32算出的use strict;my $rst = 'pop57'; # 某文件，后缀'rst'就不用改了#$rst =~ s/\..*$//;genetic_nei($rst);###================================================# 子程序###================================================# 分开Nei 1972和1978的数据sub genetic_nei { foreach (@_) { my $in = $_; my $out = "$in" . "_1972.txt"; my $outi = "$in" . "_1978.txt"; open IN, "<", "$in" . ".rst" or die "Can't open '$in': $!"; open OUT, ">", "$out" or die "Can't write to '$out': $!"; open OUTI, ">", "$outi" or die "Can't write to '$outi': $!"; my $n = 0; my $m = undef; while( ) { print OUT "$1\n\n" if /(See Nei.*292)/; print OUTI "$1\n\n" if /(See Nei.*590)/; if(/^\d+/) { s/^\d+\s+//; # 去掉开头的编号 s/ *$//; # 去掉末尾的空格 s/ +/\t/g; # 把多个空格换成一个制表符 $m = (split) unless (defined $m); if($n < $m) { print OUT; } else { print OUTI; } $n++; } } close IN; close OUT; close OUTI; divide($out, $outi); }}###================================================# 分开两组数据sub divide { foreach ( @_ ) { my $in = $_; my $out = $in; my $outi = $in; $out =~ s/^/identity_/; # 特征值 $outi =~ s/^/dist_/; # 遗传距离 open IN, "<$in" or die "Can't open '$in': $!"; open OUT, ">", "$out" or die "Can't write to '$out': $!"; open OUTI, ">", "$outi" or die "Can't write to '$outi': $!"; while( ) { if (/\*{4}/) { my $m = $`; # 遗传距离 my $n = $'; # 特征值 print OUTI "$m" . "0\n"; # 把“****”替换为“0” $m =~ s/[^\s]+/1/g; # 把遗传距离表替换为“1” print OUT "$m" . "1" ."$n"; # 之前的“****”以“1”代替 } } close IN; close OUT; close OUTI; }}
脚本2:
dist_ident_2.pl
#!perl -w#貌似运行成功#Nei 1972和1978的数据最大最小值#数据是Popgene32算出的use strict;# 从前是 @ARGV，今 @hehemy @hehe = qw(pop57);my @dist;my @ident;my ($d_1972, $d_1978, $i_1972, $i_1978);foreach ( @hehe ) { $d_1972 = "dist_" . $_ . "_1972.txt"; $d_1978 = "dist_" . $_ . "_1978.txt"; $i_1972 = "identity_" . $_ . "_1972.txt"; $i_1978 = "identity_" . $_ . "_1978.txt"; push @dist, $d_1972; push @dist, $d_1978; push @ident, $i_1972; push @ident, $i_1978;}max_dist(@dist);min_ident(@ident);print "Done!\n";#####sub max { my $max_so_far = shift @_; foreach ( @_ ) { if ($_ > $max_so_far) { $max_so_far = $_; } } $max_so_far; } ##### sub min { my $min_so_far = shift @_; foreach ( @_ ) { if ($_ < $min_so_far) { $min_so_far = $_; } } $min_so_far; }###### 求数据的最大值或最小值sub max_dist { foreach ( @_ ) { my $in = $_; my $out = $in; my @pops; open IN, "<$in" or die "Can't open '$in': $!"; $out =~ s/\.txt$//; open OUT, '>', "$out" . "_结果.txt" or die "Can't write to '_结果.txt': $!"; my $try = 0; my $i; while( ) { my @nums = split /\s+/, $_; my $num = @nums; @pops = (1 .. $num); $try = max(@nums, $try); } print OUT "\n最大值为：$try\n"; close IN; open IN, "<$in" or die "Can't open '$in': $!"; # 需要重新打开，目前不知道更好的办法 while( ) { $i++; # 第几行 my $j; foreach ( split /\s+/, $_ ) { $j++; if ($_ == $try) { print OUT $pops[$i - 1], "\t", $pops[$j - 1], "\n"; # 对应的各个坐标 } } } }}sub min_ident { foreach ( @_ ) { my $in = $_; my $out = $in; my @pops; open IN, "<$in" or die "Can't open '$in': $!"; $out =~ s/\.txt$//; open OUT, '>', "$out" . "_结果.txt" or die "Can't write to '_结果.txt': $!"; my $try = 1; my $i; while( ) { my @nums = split /\s+/, $_; my $num = @nums; @pops = (1 .. $num); $try = min(@nums, $try); } print OUT "\n最小值为：$try\n"; close IN; open IN, "<$in" or die "Can't open '$in': $!"; # 需要重新打开，目前不知道更好的办法 while( ) { $i++; # 第几行 my $j; foreach ( split /\s+/, $_ ) { $j++; if ($_ == $try) { print OUT $pops[$i - 1], "\t", $pops[$j - 1], "\n"; # 对应的各个坐标 } } } }} 脚本3:
tri2square.pl
#!perluse strict;use warnings;# 三角阵生对称矩阵my $in = 'dist_pop57_1978.txt';my $out = 'square_dist_pop57_1978.txt';my %dist;open IN, '<', $in or die "Can't open '$in': $!";open OUT, '>', $out or die "Can't write to '$out': $!";my $m = 0;while () { $m++; my $n = 1; for my $x (split) { $dist{$m}{$n} = $dist{$n}{$m} = $x; $n++; }}close IN;for my $i (1 .. $m) { for my $j (1 .. ($m-1)) { print OUT "$dist{$i}{$j}\t"; } print OUT "$dist{$i}{$m}\n";}close OUT;print "Done!\n";