Проблема с перебором столбцов в perl

Question

У меня проблемы с написанным мной сценарием. Я разбил его, чтобы определить проблему, и вот она.

Входной файл (с разделителями табуляцией):

FORMAT  Sample1        Sample2        Sample3
GT:AD:DP:GQ:PL  0/1:17,6:23:85:85,0,370 0/0:51,6:57:17:0,17,1359        0/0:3,0:3:9:0,9,99
GT:AD:DP:GQ:PGT:PID:PL  0/0:3,0:3:0:.:.:0,0,38  0/0:1,0:1:3:.:.:0,3,33  0/1:1,2:3:26:0|1:13813_T_G:81,0,26
GT:AD:DP:GQ:PGT:PID:PL  ./.:2,0:2:.:.:.:0,0,0   0/0:1,0:1:3:.:.:0,3,33  0/1:1,2:3:26:0|1:13813_T_G:81,0,26
GT:AD:DP:GQ:PL  ./.:0,0:0:.:0,0,0       1/1:0,4:4:12:131,12,0   ./.:0,0:0:.:0,0,0
GT:AD:DP:GQ:PGT:PID:PL  1/1:0,2:2:6:1|1:14590_G_A:90,6,0        0/0:3,0:3:9:.:.:0,9,98  0/0:1,0:1:3:.:.:0,3,30
GT:AD:DP:GQ:PGT:PID:PL  1/1:0,2:2:6:1|1:14590_G_A:90,6,0        0/0:3,0:3:9:.:.:0,9,98  0/0:1,0:1:3:.:.:0,3,30
GT:AD:DP:GQ:PGT:PID:PL  1/1:0,2:2:6:1|1:14590_G_A:90,6,0        0/0:3,0:3:9:.:.:0,9,98  0/0:1,0:1:3:.:.:0,3,30
GT:AD:DP:GQ:PGT:PID:PL  1/1:0,2:2:6:1|1:14590_G_A:90,6,0        0/0:2,0:2:6:.:.:0,6,72  0/0:1,0:1:3:.:.:0,3,30
GT:AD:DP:GQ:PL  1/1:0,7:7:21:186,21,0   0/1:5,4:9:79:79,0,103   ./.:1,0:1:.:0,0,0

Желаемый результат (возьмите первые 3 символа перед двоеточием из каждого sample) в каждой строке и распечатайте каждую строку:

GT:AD:DP:GQ:PL  0/1 0/0       0/0
GT:AD:DP:GQ:PGT:PID:PL  0/0  0/0  0/1
GT:AD:DP:GQ:PGT:PID:PL  ./.   0/0  0/1
GT:AD:DP:GQ:PL  ./.       1/1   ./.
GT:AD:DP:GQ:PGT:PID:PL  1/1        0/0  0/0
GT:AD:DP:GQ:PGT:PID:PL  1/1       0/0  0/0
GT:AD:DP:GQ:PGT:PID:PL  1/1       0/0  0/0
GT:AD:DP:GQ:PGT:PID:PL  1/1      0/0  0/0
GT:AD:DP:GQ:PL  1/1   0/1  ./.

Код, который я использую для этого шага, не создает правильные коды 0/0, 0/1, 0/2, как ожидалось для каждой строки. Я думаю, что это проблема того, как я написал для l oop, но я не уверен.

#!/usr/bin/perl
use strict;

my $inputfile1 = $ARGV[0];
open (FILE1, $inputfile1) or die "Uh oh.. unable to find file $inputfile1"; ##Opens input file

my @file1 = <FILE1>; #loads inputfile1 data into array
close FILE1;


my (@colsplit, @genotypes1, @genotypes2, @genotypes3, @joined); 
foreach my $line(@file1) { ## process each line, splitting columns and move onto next line
    @colsplit = split("\t", $line);
        push (@joined, $colsplit[0]);
            foreach my $lines(@colsplit) {
                if ($colsplit[1] =~ m/(^0\/1)/ || $colsplit[1] =~ m/(^0\/0)/ || $colsplit[1]=~ m/(^1\/0)/ || $colsplit[1] =~ m/(^1\/1)/ || $colsplit[1] =~ m/(^.\/.)/) {
                    push (@genotypes1, $1);
                    }
                    if ($colsplit[2] =~ m/(^0\/1)/ || $colsplit[2] =~ m/(^0\/0)/ || $colsplit[2] =~ m/(^1\/0)/ || $colsplit[2] =~ m/(^1\/1)/ || $colsplit[2] =~ m/(^.\/.)/) {
                    push (@genotypes2, $1);
                    }
                    if ($colsplit[3] =~ m/(^0\/1)/ || $colsplit[3] =~ m/(^0\/0)/ || $colsplit[3] =~ m/(^1\/0)/ || $colsplit[3] =~ m/(^1\/1)/ || $colsplit[3] =~ m/(^.\/.)/) {
                    push (@genotypes3, $1); 
                    }       
                }
            }



my $i = 0;
foreach my $line(@joined) {
    if ($line =~ m/GT/) {
print "$line\t$genotypes1[$i]\t$genotypes2[$i]\t$genotypes3[$i]\n";
$i++;
    }}

Я думаю, проблема может заключаться в том, что после сопоставления первого столбца sample1 он переходит ко второй строке, а не выполняет итерацию по второму столбцу sample2. Я не понимаю, как я все испортил! Это сводит меня с ума!

Мой текущий результат:

GT:AD:DP:GQ:PL  0/1 0/0 0/0
GT:AD:DP:GQ:PGT:PID:PL  0/1 0/0 0/0
GT:AD:DP:GQ:PGT:PID:PL  0/1 0/0 0/0
GT:AD:DP:GQ:PL  0/1 0/0 0/0
GT:AD:DP:GQ:PGT:PID:PL  0/0 0/0 0/1
GT:AD:DP:GQ:PGT:PID:PL  0/0 0/0 0/1
GT:AD:DP:GQ:PGT:PID:PL  0/0 0/0 0/1
GT:AD:DP:GQ:PGT:PID:PL  0/0 0/0 0/1
GT:AD:DP:GQ:PL  ./. 0/0 0/1

Это явно не то, что я хочу!

Любая помощь будет принята с благодарностью.

Пс. Я новичок в этом, так что go легко.

Answer 1

Вопрос кажется ясным, хранить данные до : в каждом столбце (кроме первого). Но тогда меня немного смущает попытка кода, который без нужды использует определенные c шаблоны для столбцов.

Вот простой вариант того, что описано

use warnings;
use strict;
use feature 'say';

my $header_line = <>;   # drop the first line

while (<>) {            # line by line from files given on cmdline, or STDIN
    chomp;

    my ($fmt_col, @cols) = split /\t/;   # (but sample has spaces, not tabs)

    s/(.*?):.*/$1/ for @cols;            # keep up to (first) : in each field
    
    say join "\t", $fmt_col, @cols;      # print fields joined by tabs
}

<> читает все строки из всех файлов, указанных в командной строке, или STDIN; поэтому отправьте имя файла для обработки в командной строке при запуске этой программы.

Обратите внимание, что в опубликованном образце нет табуляции, а скорее пробелы; поэтому приведенный выше код не сработает, если его скопировать. Либо замените пробелы на вкладки для тестирования, либо измените split /\t/; на split; (чтобы использовать значение по умолчанию для разделения, которое представляет собой любое количество любых пробелов).

Все поля, кроме первого, изменяются так что остаются только символы до первого :.

Это делается с использованием того факта, что каждый элемент, обработанный в foreach l oop («топикализатор»), привязан к текущему обрабатываемому элементу . Поэтому, когда регулярное выражение s/// изменяет его, соответствующий элемент @cols изменяется. Если это кажется слишком жарким для желудка, пожалуйста, непременно напишите это красиво и медленно.

Answer 2

Один из возможных способов - использовать модификатор продолжения (c) сопоставления регулярного выражения. Это приводит к тому, что операция сопоставления начинается с того места, где последний нашел совпадение. Таким образом можно обрабатывать каждое поле строки.

#!/usr/bin/perl

use strict;
use warnings;

my $fh;
$ARGV[0] && open($fh, $ARGV[0]) || die();

# discard first line;
<$fh>;

foreach my $line (<$fh>) {
  chomp($line);

  # capture every non tab character from the beginning of the line;
  # globally match the pattern repeatedly in the string (g modifier)
  # keep the current position during repeated matching (c modifier);
  $line =~ m/^([^\t]*)/gc;
  print("$1");

  # capture every non colon character after a tab character;
  # globally match the pattern repeatedly in the string (g modifier);
  # keep the current position during repeated matching (c modifier);
  while ($line =~ m/\t([^:]*)/gc) {
    print("\t$1");
  }

  print("\n");
}

Answer 3

Я считаю, что решил проблему. Я удалил foreach my $lines(@colsplit) { и теперь он работает! Код ниже:

#!/usr/bin/perl
use strict;

my $inputfile1 = $ARGV[0];
open (FILE1, $inputfile1) or die "Uh oh.. unable to find file $inputfile1"; ##Opens input file

my @file1 = <FILE1>; #loads inputfile1 data into array
close FILE1;


my (@colsplit, @genotypes1, @genotypes2, @genotypes3, @joined); 
foreach my $line(@file1) { ## process each line, splitting columns and move onto next line
    @colsplit = split("\t", $line);
        push (@joined, $colsplit[0]);
                if ($colsplit[1] =~ m/(^0\/1)/ || $colsplit[1] =~ m/(^0\/0)/ || $colsplit[1]=~ m/(^1\/0)/ || $colsplit[1] =~ m/(^1\/1)/ || $colsplit[1] =~ m/(^.\/.)/) {
                    push (@genotypes1, $1);
                    }
                    if ($colsplit[2] =~ m/(^0\/1)/ || $colsplit[2] =~ m/(^0\/0)/ || $colsplit[2] =~ m/(^1\/0)/ || $colsplit[2] =~ m/(^1\/1)/ || $colsplit[2] =~ m/(^.\/.)/) {
                    push (@genotypes2, $1);
                    }
                    if ($colsplit[3] =~ m/(^0\/1)/ || $colsplit[3] =~ m/(^0\/0)/ || $colsplit[3] =~ m/(^1\/0)/ || $colsplit[3] =~ m/(^1\/1)/ || $colsplit[3] =~ m/(^.\/.)/) {
                    push (@genotypes3, $1); 
                }
            }



my $i = 0;
foreach my $line(@joined) {
    if ($line =~ m/GT/) {
print "$line\t$genotypes1[$i]\t$genotypes2[$i]\t$genotypes3[$i]\n";
$i++;
    }}

Спасибо @zdim, особенно за то, что он показал мне более элегантное решение. E