操縱多個線路使用Perl

Question

我有幾個到幾百形式

1st 2n 2p 3n 3p 4n 4p 
1ABJa 2 20 8 40 3 45 
1ABJb 2 40 8 80 3 45 
2C3Da 4 50 5 39 2 90 
2D4Da 1 10 8 90 8 65 

（製表符分隔的文件）

行文件從這個文件，我想操縱具有相似的所有行在第1列（即1ABJa和1ABJb）中有4個開始字符，並且執行：

• 對於第1列，合併兩個名稱以維護常用字符;
• 列2n, 3n, 4n...這些數字將相加;
• 列2p, 3p, 4p, ...數字將被平均。

（請注意，這可以通過列位置而不是名稱來指定）。 然後這將產生：

1st 2n 2p 3n 3p 4n 4p 
1ABJab 4 30 16 60 6 45  
2C3Da 4 50 5 39 2 90 
2D4Da 1 10 8 90 8 65 

你會如何解決這個問題？

這可能是最複雜的方式來做到這一點，但它在這裏：我正在考慮創建第一列所有4字符獨特元素的數組。然後，對於該數組，運行一個可找到與這4個字符匹配的所有實例的循環。如果有超過1個實例，請標識它們，推動列並對其進行處理。下面是我到現在爲止點：

#!/usr/local/bin/perl 
use strict; 
use warnings; 
use feature 'say'; 
use List::MoreUtils qw(uniq); 

my $dir='My\\Path\\To\\Directory'; 
open my $in,"<", "$dir\\my file.txt" or die; 
my @uniqarray; my @lines; 

#collects unique elements in 1st column and changes them to 4-character words 
while (my $line = <$in>) { 
    chomp $line; 
    @lines= split '\t', $line; 
    if (!grep /$lines[0]/, @uniqarray){ 
     $lines[0] =~ s/^(.{4}).*/$1/; 
     push @uniqarray,$lines[0]; 
    } 
} 

my @l; 
#for @uniqarray, find all rows in the input that match them. if more than 1 row is found, manipulate the columns 
while (my $something=<$in>) { 
    chomp $something; 
    @l= split '\t', $something; 
    if (map $something =~ m/$_/,@uniqarray){ 
     **[DO STUFF]** 
    } 
} 

print join "\n", uniq(@uniqarray); 

close $in; 

Answer 1

這似乎是你所需要的。它爲每個不同的四字符前綴保留一組哈希數據：在關鍵字n下具有相同前綴的記錄數的計數，該數組保存關鍵字totals下該前綴的列總數，在關鍵字suffixes下看到的前綴的所有後綴。

第一次看到它們時，會在數組@prefixes中添加前綴，以便可以按照與輸入相同的順序顯示輸出。

這只是一個積累數據然後以所需格式轉儲它的問題，將totals數組的所有偶數列除以n。

use strict; 
use warnings; 

open my $fh, '<', 'data.txt' or die $!; 

print scalar <$fh>; # Copy header 

my %data; 
my @prefixes; 

while (<$fh>) { 
    chomp; 
    my @fields = split /\t/; 
    my ($prefix, $suffix) = shift(@fields) =~ /(.{4})(.*)/; 
    push @prefixes, $prefix unless $data{$prefix}; 
    ++$data{$prefix}{n}; 
    ++$data{$prefix}{suffixes}{$suffix}; 
    $data{$prefix}{totals}[$_] += $fields[$_] for 0 .. $#fields; 
} 

for my $prefix (@prefixes) { 
    my $val  = $data{$prefix}; 
    my $totals = $val->{totals}; 
    for (my $i = 1; $i < @$totals; $i += 2) { 
    $totals->[$i] /= $val->{n}; 
    } 
    my $suffixes = join '', sort keys %{ $val->{suffixes} }; 
    print join("\t", "$prefix$suffixes", @$totals), "\n"; 
} 

輸出

1st  2n 2p 3n 3p 4n 4p 
1ABJab 4 30 16 60 6 45 
2C3Da 4 50 5 39 2 90 
2D4Da 1 10 8 90 8 65 

Answer 2

如何：

my $result; 
my $head = <DATA>; 
while(<DATA>) { 
    chomp; 
    my @l = split/\s+/; 
    my ($k1,$k2) = ($l[0] =~ /^(....)(.*)$/); 
    $result->{$k1}{more} .= $k2 // ''; 
    $result->{$k1}{nbr}++; 

    ; 
    $result->{$k1}{n}{2} += $l[1]; 
    $result->{$k1}{n}{3} += $l[3]; 
    $result->{$k1}{n}{4} += $l[5]; 
    $result->{$k1}{p}{2} += $l[2]; 
    $result->{$k1}{p}{3} += $l[4]; 
    $result->{$k1}{p}{4} += $l[6]; 
} 

print $head; 
foreach my $k (keys %$result) { 
    print $k,$result->{$k}{more},"\t"; 
    for my $c (2,3,4) { 
     printf("%d\t",$result->{$k}{n}{$c}); 
     if (exists($result->{$k}{nbr}) && $result->{$k}{nbr} != 0) { 
      printf("%d\t",$result->{$k}{p}{$c}/$result->{$k}{nbr}); 
     } else { 
      printf("%d\t",0); 
     } 
    } 
    print "\n"; 
} 

輸出：

1st  2n 2p 3n 3p 4n 4p 
2D4Da 1 10 8 90 8 65 
1ABJab 4 30 16 60 6 45 
2C3Da 4 50 5 39 2 90