请教perl高手

pitonas

偶试试...
for windows only

1. use 5.018;
   
2. 
   
3. open my $f1, 'file1.txt';
   
4. open my $f2, 'file2.txt';
   
5. 
   
6. my $title = join "\t", split( /\s+/, <$f1> ), ( split /\s+/, <$f2> )[ 4 .. 9 ];
   
7. say $title;
   
8. my @head = (0) x 12;
   
9. my @tail = (0) x 6;
   
10. my %f;
    
11. 
    
12. while (<$f1>) {
    
13.     chomp;
    
14.     my @a = split /\t/;
    
15.     push @{ $f{"@a[ 0 .. 3 ]"} }, @a;
    
16. }
    
17. 
    
18. while (<$f2>) {
    
19.     chomp;
    
20.     my @a   = split /\t/;
    
21.     my $key = "@a[ 0 .. 3 ]";
    
22.     exists $f{$key}
    
23.       ? push @{ $f{$key} }, @a[ 4 .. $#a ]
    
24.       : push @{ $f{$key} }, @a[ 0 .. 3 ], @head, @a[ 4 .. $#a ];
    
25. }
    
26. 
    
27. say join "\t", @{ $f{$_} }, @{ $f{$_} } > 16 ? () : @tail
    
28.   for sort { $f{$a}[0] cmp $f{$b}[0] || $f{$a}[1] <=> $f{$b}[1] } keys %f;
    
29. 
    

复制代码

回复 1# owwa


   

owwa

回复 11# pitonas

多谢兄弟，由于文件较大，最好ubuntu中应用。

pitonas

{:2_172:} ok:
请确保您的文件格式是
unix 格式 "\n"
不是
windows 格式 "\r\n"

1. #!/usr/bin/perl
   
2. 
   
3. open my $f1, 'file1.txt';
   
4. open my $f2, 'file2.txt';
   
5. 
   
6. chomp( my $t1 = <$f1> );
   
7. my $t2 = ( split /\t/, <$f2>, 5 )[-1];
   
8. print join "\t", $t1, $t2;
   
9. 
   
10. my $head = join "\t", (0) x 12;
    
11. my $tail = join( "\t", (0) x 6 ) . $/;
    
12. my %f;
    
13. 
    
14. while (<$f1>) {
    
15.     chomp;
    
16.     my @a = split /\t/, $_, 5;
    
17.     $f{ join "\t", @a[ 0 .. 3 ] } = [ @a[ 0, 1 ], $a[4] ];
    
18. }
    
19. 
    
20. while (<$f2>) {
    
21.     my @a = split /\t/, $_, 5;
    
22.     my $key = join "\t", @a[ 0 .. 3 ];
    
23.     exists $f{$key}
    
24.       ? push @{ $f{$key} }, $a[4]
    
25.       : push @{ $f{$key} }, @a[ 0, 1 ], $head, $a[4];
    
26. }
    
27. 
    
28. print join "\t", $_, $f{$_}[2], @{ $f{$_} } == 4 ? $f{$_}[3] : $tail
    
29.   for sort { $f{$a}[0] cmp $f{$b}[0] || $f{$a}[1] <=> $f{$b}[1] } keys %f;
    
30. 
    

复制代码

回复 12# owwa


   

owwa

回复 13# pitonas

多谢兄弟的帮助！其实文件file1和file2的列数是不固定的，file1还可能有g,h等列，file2还可能有r,s等列，但1-4列是固定的。
   

pitonas

{:2_179:} 这个问题比较难, 很难搞

请确保您的 file1.txt, file2.txt 文件格式
是 unix 格式 "\n"
不是 windows 格式 "\r\n"


perl script.pl file1.txt file2.txt > new.txt

1. #!/usr/bin/perl
   
2. 
   
3. open my $f1, $ARGV[0];
   
4. open my $f2, $ARGV[1];
   
5. 
   
6. my $title1 = <$f1>;
   
7. my $title2 = ( split /\t/, <$f2>, 5 )[-1];
   
8. my $col1   = ( $title1 =~ tr/\t// ) + 1 - 4;
   
9. my $col2   = ( $title2 =~ tr/\t// ) + 1;
   
10. my $void1  = join( "\t", (0) x $col1 );
    
11. my $void2  = join( "\t", (0) x $col2 ) . $/;
    
12. 
    
13. chomp $title1;
    
14. print join "\t", $title1, $title2;
    
15. my %f;
    
16. 
    
17. while (<$f1>) {
    
18.     chomp;
    
19.     my @a = split /\t/, $_, 5;
    
20.     $f{ $a[0] }{ join "\t", @a[ 1 .. 3 ] } = [ @a[ 1, -1 ] ];
    
21. }
    
22. 
    
23. while (<$f2>) {
    
24.     my @a = split /\t/, $_, 5;
    
25.     my $key = join "\t", @a[ 1 .. 3 ];
    
26.     exists $f{ $a[0] }{$key}
    
27.       ? push @{ $f{ $a[0] }{$key} }, $a[-1]
    
28.       : push @{ $f{ $a[0] }{$key} }, $a[1], $void1, $a[-1];
    
29. }
    
30. 
    
31. my @chrom = map { $_->[0] } sort { $a->[1] <=> $b->[1] }
    
32.   map { [ $_, substr $_, 3 ] } keys %f;
    
33. 
    
34. for my $chr (@chrom) {
    
35.     print "$chr\t$_\t$f{$chr}{$_}[1]\t", $f{$chr}{$_}[2] || $void2
    
36.       for sort { $f{$chr}{$a}[0] <=> $f{$chr}{$b}[0] }
    
37.         keys %{ $f{$chr} };
    
38. }
    
39. 
    

复制代码

回复 14# owwa


   

huang6894

回复 15# pitonas


    我是来膜拜大神的~mark帖~

owwa

回复 15# pitonas

非常非常感谢！

   

yestreenstars

我也来一发~{:2_172:}

1. #!/usr/bin/perl
   
2. open F1, 'a' or die;
   
3. open F2, 'b' or die;
   
4. 
   
5. my $t1 = <F1>;
   
6. my $t2 = <F2>;
   
7. my $str1 = join "\t", (0) x ( ( $t1 =~ s/\t/\t/g ) - 3 );
   
8. my $str2 = join "\t", (0) x ( ( $t2 =~ s/\t/\t/g ) - 3 );
   
9. $t2 =~ s/(\S+\t){4}//;
   
10. $t1 =~ s/\n/\t$t2/;
    
11. print $t1;
    
12. 
    
13. chomp ( my @f1 = <F1> );
    
14. chomp ( my @f2 = <F2> );
    
15. 
    
16. my ( %h1, %h2 );
    
17. 
    
18. map { $f1[$_] =~ s/((\S+\t){4})//; $h1{$1} = $f1[$_] } 0..$#f1;
    
19. map { $f2[$_] =~ s/((\S+\t){4})//; $h2{$1} = $f2[$_] } 0..$#f2;
    
20. 
    
21. exists $h2{$_} ? push @result, "$_$h1{$_}\t$h2{$_}$/" : push @result, "$_$h1{$_}\t$str2$/" for keys %h1;
    
22. exists $h1{$_} || push @result, "$_$str1\t$h2{$_}$/" for keys %h2;
    
23. 
    
24. map { print $_->[1] } sort { $a->[0] <=> $b->[0] } map { [ (split)[1], $_ ] } @result;

复制代码

owwa

回复 18# yestreenstars

谢谢兄弟！
   

yestreenstars

回复 19# owwa
我将你的帖子转到Shell版了，楼主有空的话可以去看看，比较一下awk和perl的效率~{:2_168:}
http://bbs.chinaunix.net/forum.php?mod=viewthread&tid=4142697&fromuid=26669282