Сортировать таблицу (или 2-мерный массив) по одинаковым значениям в столбце

Question

Пример.

Если ввод

Вывод должен быть

Таким образом, каждая строка должна содержать только одинаковые значения или undef, если в исходном несортированном столбце такой строки не было. Значения в столбцах должны быть отсортированы по алфавиту.

Как реализовать этот тип сортировки?

P.S. Исходное задание - у нас есть несколько модулей, и мы хотим визуально сравнить их для функций с похожими именами.

Answer 1

Просто еще одно другое решение, использующее хэши и массивы и Hash :: Merge.Глядя на ваш пример, я пришел к выводу, что каждое значение из таблицы может храниться как одна запись хеша, если вы отслеживаете, к какому столбцу они принадлежат.После создания несортированного хэша программа завершает работу с примером алгоритма печати, чтобы извлечь данные в нужном формате.

use warnings;
use strict;
use Hash::Merge ;

my @data = (
    { name => 'Foo', funcs => [qw/abc def ghi xyz/] },
    { name => 'Bar', funcs => [qw/def jkl mno uvw xyz/] },
    { name => 'Baz', funcs => [qw/abc uvw xyz/] },
);

my $merger = Hash::Merge->new('RETAINMENT_PRECEDENT');
my $unsorted = {} ;
for my $i ( 0..$#data) {
    my $tmpH = {} ;
    foreach( @{$data[$i]->{funcs}} ) {
        if( exists $tmpH->{ $_ } ) {
            push @{$tmpH->{ $_ }}, $i ;
        } else {
            $tmpH->{ $_ } = [ $i ] ;
        }
    } ;
    $unsorted = $merger->merge( $unsorted, $tmpH ) ;
}
print "Foo\tBar\tBaz\n" ;
foreach ( sort keys %{$unsorted} ) {
    my @txt;
    @txt[@{$unsorted->{ $_ }}] = ($_) x @{$unsorted->{ $_ }} ;
    {
        no warnings 'uninitialized';
        printf("%s\t%s\t%s\n", $txt[0], $txt[1], $txt[2]) ; 
    }
}
__END__
Foo     Bar     Baz
abc             abc
def     def
ghi
        jkl
        mno
        uvw     uvw
xyz     xyz     xyz

Answer 2

Что-то вроде этого может быть?

use warnings;
use strict;

my @data = (
    { name => 'Foo', funcs => [qw/abc def ghi xyz/] },
    { name => 'Bar', funcs => [qw/def jkl mno uvw xyz/] },
    { name => 'Baz', funcs => [qw/abc uvw xyz/] },
);

my %allfuncs = ( map { map {$_=>undef} @{$$_{funcs}} } @data );
$$_{funcs} = { %allfuncs, map {$_=>1} @{$$_{funcs}} } for @data;

use Data::Dump;
dd @data;

# just for output:
use List::Util qw/max/;
my $maxlen = max map {length} map({$$_{name}} @data), keys(%allfuncs);
my $fmt = join('  ', ("%${maxlen}s") x @data)."\n";
printf $fmt, map { $$_{name} } @data;
for my $f (sort keys %allfuncs) {
    printf $fmt, map { $$_{funcs}{$f}?$f:'' } @data;
}

Выход:

(
  {
    funcs => { abc => 1, def => 1, ghi => 1, jkl => undef, mno => undef, uvw => undef, xyz => 1 },
    name  => "Foo",
  },
  {
    funcs => { abc => undef, def => 1, ghi => undef, jkl => 1, mno => 1, uvw => 1, xyz => 1 },
    name  => "Bar",
  },
  {
    funcs => { abc => 1, def => undef, ghi => undef, jkl => undef, mno => undef, uvw => 1, xyz => 1 },
    name  => "Baz",
  },
)
Foo  Bar  Baz
abc       abc
def  def     
ghi          
     jkl     
     mno     
     uvw  uvw
xyz  xyz  xyz

---

Обновление: Если ваши входные данные поступают в виде AoA, это займет @table и даст тот же @data, что и выше (в основном это транспонирует AoA, а затем создает хеш-структуру) :

my @table = ( [qw/Foo Bar Baz/], [qw/abc def abc/], [qw/def jkl uvw/],
    [qw/ghi mno xyz/], [qw/xyz uvw/], [undef, qw/xyz/] );
my @data;
for my $col ( 0 .. $table[0]->$#* )
    { push @data, [ map {$_->[$col]//()} @table ] }
@data = map { {name=>shift @$_, funcs=>$_} } @data;

А если вам нужен выходной формат для AoA:

my @out = ( [map {$$_{name}} @data] );
for my $f (sort keys %allfuncs)
    { push @out, [ map {$$_{funcs}{$f}?$f:undef} @data ] }

Производит @out:

(
  ["Foo", "Bar", "Baz"],
  ["abc", undef, "abc"],
  ["def", "def", undef],
  ["ghi", undef, undef],
  [undef, "jkl", undef],
  [undef, "mno", undef],
  [undef, "uvw", "uvw"],
  ["xyz", "xyz", "xyz"],
)

Answer 3

Небольшой ручной, но, надеюсь, ясный подход к «заполнению» пропущенных мест: соберите отсортированную ссылку на все значения и используйте ее для «заполнения» (с пустым) пропущенных элементов в каждом массивеref-столбце

use warnings;
use strict;
use feature 'say';
use Data::Dump qw(dd);
use List::MoreUtils qw(uniq);

my @data = (
    [ qw(abc def ghi xyz) ],
    [ qw(def jkl mno uvw xyz) ],
    [ qw(abc uvw xyz) ]
);    
my @all = uniq sort { $a cmp $b } map { @$_ } @data;  # reference

# Changes @data in place. Use on deep copy to preserve the original
for my $ary (@data) {
    my $cmp_at = 0;
    my @res;
    for my $i (0..$#all) {
        if ($ary->[$cmp_at] eq $all[$i]) {
            push @res, $ary->[$cmp_at];
            ++$cmp_at;
        }
        else {
            push @res, undef;
        }
    }
    $ary = \@res;  # overwrite arrayref in @data
}

dd \@data;

Другим способом является построчное сканирование, проверка и печать каждого элемента, снова используя список ссылок. Я думаю, что используемая здесь обработка по столбцам должна быть более гибкой и общей.

Вышеуказанные отпечатки

[
  ["abc", "def", "ghi", undef, undef, undef, "xyz"],
  [undef, "def", undef, "jkl", "mno", "uvw", "xyz"],
  ["abc", undef, undef, undef, undef, "uvw", "xyz"],
]

где строка " undef ", созданная Data :: Dump , указывает на элементы массива без нуля.

---

Теперь @data можно использовать для печати в выбранном формате, например

use List::Util qw(max);

my $fmt = '%' . (max map { length } @all) . 's';
say join "\t", map { sprintf $fmt, $_ } qw(Foo Bar Baz);    
for my $i (0..$#{$data[0]}) {
    say join "\t", map { sprintf $fmt, $_->[$i]//'' } @data;
}

что печатает таблицу в порядке желаемого «вывода». Для быстрого выравнивания я использую ширину самого длинного слова для всех полей; это легче всего улучшить с помощью модуля форматирования текста.

Если это относится к электронной таблице, например к таблицам в вопросе, тогда просто объедините поля запятой

open my $fh, '>', 'out.csv' or die "Can't open: $!";
say $fh join ',', qw(Foo Bar Baz);
foreach my $i (0..$#{$data[0]}) {
    say $fh join ',', map { $_->[$i]//'' } @data;
}

Answer 4

Следующий код должен сделать это, выходной формат CSV:

#!/usr/bin/perl
use strict;
use warnings;

use Text::CSV_XS qw( );

my $csv = Text::CSV_XS->new({ binary => 1, auto_diag => 2 });

my @headers = qw(Foo Bar Baz);
my @columns = (
    [qw/abc def ghi xyz/],
    [qw/def jkl mno uvw xyz/],
    [qw/abc uvw xyz/],
);

my %output;
my $N       = scalar(@columns);
my @new_row = ('') x $N;

foreach my $index (0..$N-1) {
    my $column = $columns[$index];

    foreach my $key (@{ $column }) {
        $output{$key} ||= [ @new_row ];
        $output{$key}->[$index] = $key;
    }
}

$csv->say(\*STDOUT, \@headers);

# NOTE: add {....} after sort for special sorting requirements
foreach my $key (sort keys %output) {
    $csv->say(\*STDOUT, $output{$key});
}

Пример вывода:

$ perl dummy.pl
Foo,Bar,Baz,
abc,,abc,
def,def,,
ghi,,,
,jkl,,
,mno,,
,uvw,uvw,
xyz,xyz,xyz,

ПРИМЕЧАНИЕ: выше по умолчаниюалгоритм сортировки, но вы можете вставить свой собственный, например,

# reverse sort
foreach my $key (sort { $b cmp $a } keys %output) {

Спасибо за вопрос.Это было весело: -)

---

EDIT2: угадывание по формату вопроса, ввод также может быть в CSV, поэтому вариант алгоритма на основе строк может быть большесоответствующий.

#!/usr/bin/perl
use strict;
use warnings;

use Text::CSV_XS qw( );

my $csv = Text::CSV_XS->new({ binary => 1, auto_diag => 2 });

my $headers;
my @new_row;

my %keys;
my $line = 0;
while ( my $row = $csv->getline(\*STDIN) ) {
    if ($line == 0) {
        $headers = $row;
        @new_row = ('') x @$row;
    } else {
        foreach my $index (0..$#$row) {
            my $key = $row->[$index];
            $keys{$key} ||= [ @new_row ];
            $keys{$key}->[$index] = $key;
        }
    }

    $line++;
}

# delete "undefined" key
delete $keys{''};

$csv->say(\*STDOUT, $headers);
# NOTE: add {....} after sort for special sorting requirements
$csv->say(\*STDOUT, $keys{$_}) foreach (sort keys %keys);

Пример вывода:

$ cat input.csv 
Foo,Bar,Baz
abc,def,abc
def,jkl,uvw
ghi,mno,xyz
xyz,uvw,
,xyz,

$ perl dummy.pl <input.csv 
Foo,Bar,Baz
abc,,abc
def,def,
ghi,,
,jkl,
,mno,
,uvw,uvw
xyz,xyz,xyz