Crear un archivo de jerarquía usando perl

Question

Mi tarea es crear un archivo de jerarquía principal-secundario usando perl.

Archivo de entrada de muestra (delimitado por tabuladores). Los registros se organizarán en el archivo en orden aleatorio y el "padre" puede aparecer después del "niño".

S5 S3 
S5 S8 
ROOT S1 
S1 S7 
S2 S5 
S3 S4 
S1 S2 
S4 77 
S2 S9 
S3 88 

Ejemplo de archivo de salida (delimitado por tabuladores)

ROOT S1 S2 S5 S3 S4 77 
ROOT S1 S2 S5 S3 88 
ROOT S1 S7 
ROOT S1 S2 S5 S8 
ROOT S1 S2 S9 

El código que produce el archivo de salida por encima de

use strict; 

# usage: perl parent_child_generator.pl input.txt output.txt 

my $input0=$ARGV[0] or die "must provide input.txt as the first argument\n"; 
my $output1=$ARGV[1] or die "must provide output.txt as the second argument\n"; 

open(IN0,"<",$input0) || die "Cannot open $input0 for reading: $!"; 
open(OUT1,">",$output1) || die "Cannot open $output1 for writing: $!"; 

sub trim 
{ 
    my $string=shift; 
$string=~s/\r?\n$//; 
$string=~s/^\s+//; 
$string=~s/\s+$//; 
return $string; 
} 

sub connectByPrior 
{ 
my $in_child=$_[0]; 
my %in_hash=%{$_[1]}; 
my @anscestor_arr; 

for (sort keys %in_hash) 
{ 
    my $key=$_; 
    my @key_arr=split(/\t/,$key); 
    my $parent=$key_arr[0]; 
    my $child=$key_arr[1]; 

    if ($in_child eq $child) 
    { 
     push (@anscestor_arr,$parent); 
     @anscestor_arr=(@{connectByPrior($parent,\%in_hash)},@anscestor_arr); 
     last; 
    } 
} 
return \@anscestor_arr; 
} 

my %parent_hash; 
my %child_hash; 
my %unsorted_hash; 
while(<IN0>) 
{ 
my @cols=split(/\t/); 
for (my $i=0; $i < scalar(@cols); $i++) 
{ 
    $cols[$i]= trim($cols[$i]); 
} 

my $parent=$cols[0]; 
my $child=$cols[1]; 
my $parent_child="$parent\t$child"; 

$parent_hash{$parent}=1; 
$child_hash{$child}=1; 
$unsorted_hash{$parent_child}=1; 
} 
close(IN0); 

my @lev0_arr; 
for (sort keys %child_hash) 
{ 
my $rec=$_; 
if (!exists($parent_hash{$rec})) 
{ 
    push (@lev0_arr,$rec); 
} 
} 

for (@lev0_arr) 
{ 
my $child=$_; 
my @anscestor_arr=@{connectByPrior($child,\%unsorted_hash)}; 
push (@anscestor_arr,$child); 
print OUT1 join("\t",@anscestor_arr)."\n"; 
} 

Pregunta: El código funciona bien si el archivo de entrada no es demasiado grande. El archivo de entrada real contiene más de 200k líneas y el código está tardando demasiado tiempo en procesar la salida. ¿Qué mejoras/cambios sugieres para que no tardes demasiado en procesar?

Answer 1

Lo primero que viene a la mente, aunque no está relacionado con su pregunta real, es que al menos debería considerar hacer su interfaz más flexible. Si lee desde <> e imprime a STDOUT, podrá tomar entradas desde STDIN o una lista de archivos de tamaño arbitrario en la línea de comandos, mientras que la salida puede verse en la consola o redirigirse a un archivo con sólo un cambio menor en la convención de llamada:

parent_child_generator.pl input1.txt input2.txt input3.txt > output.txt 

Otro detalle es que la $string=~s/\r?\n$//; en trim es innecesaria [1]. $string=~s/\s+$//; se hará cargo de ella:

$ perl -e 'my $foo = "test\r\n"; print "--$foo--\n"; $foo =~ s/\s+$//; print "--$foo--\n";' 
--test 
-- 
--test-- 

Cómo llegar a su problema de rendimiento (por fin ...), el problema central es que usted está llamando connectByPrior para cada elemento en @lev0_arr [2] y connectByPrior no sólo sobre los bucles %unsorted_hash [3] cada vez que se invoca, pero, dentro de ese ciclo, ¡se llama de manera recursiva! En una primera aproximación, está entre O (n^2 log n) y O (n^3), dependiendo de la forma de tus árboles, lo cual es simplemente horrible. Debe evitar tocar cada dato varias veces por cada otra información que reciba.

Entonces, ¿cómo iba a hacer eso? Mi primer pensamiento es usar un hash para hacer un seguimiento de mis nodos raíz (todos los que no tienen nada que los vincule) y un hash de hashes (HoH) para hacer un seguimiento de todos los enlaces. A medida que se ve cada línea de entrada, divídala en padre e hijo, como lo está haciendo. Si el padre no tiene una entrada en el enlace HoH, agréguelo al hash raíz. Si el niño está en el hash raíz, quítelo. Si el niño no está en los enlaces HoH, agregue un hashref vacío (para que sepamos en el futuro que no es una raíz). Finalmente, agregue una entrada en el enlace HoH que indica que el padre se vincula al niño.

La salida es simplemente una cuestión de iterar sobre el hash de raíz (su lista de puntos de partida) y, para cada nodo que se encuentra allí, imprimiendo recursivamente los elementos secundarios de ese nodo.

así:

#!/usr/bin/perl 

use strict; 
use warnings; 
use 5.010; 

my %root; 
my %link; 

while (<>) { 
    my ($parent, $child) = split /\t/, $_, 2; 
    next unless defined $parent and defined $child; 
    $_ = trim($_) for ($parent, $child); 

    $root{$parent} = 1 unless exists $link{$parent}; 
    delete $root{$child}; 
    $link{$child} ||= {}; 
    $link{$parent}{$child} = 1; 
} 

print_links($_) for sort keys %root; 

exit; 

sub trim { 
    my $string=shift; 
    $string=~s/^\s+//; 
    $string=~s/\s+$//; 
    return $string; 
} 

sub print_links { 
    my @path = @_; 

    my %children = %{$link{$path[-1]}}; 
    if (%children) { 
    print_links(@path, $_) for sort keys %children; 
    } else { 
    say join "\t", @path; 
    } 
} 

Dada su entrada ejemplo, esto produce la salida:

ROOT S1  S2  S5  S3  88 
ROOT S1  S2  S5  S3  S4  77 
ROOT S1  S2  S5  S8 
ROOT S1  S2  S9 
ROOT S1  S7 

Desde esta versión sólo se toca cada enlace una vez para la entrada y una vez para la salida, se debe escalar más -o menos linealmente a medida que aumenta la cantidad de datos de entrada.

(Por supuesto, Sinan es correcto sugerir que hay que ir a CPAN si realmente está buscando para hacer las cosas, pero me estaba divirtiendo con él.)

Editar: Código debe probar si $parent y $child se definen, no si son ciertos, según el comentario de Sinan.

[1] Normalmente debería utilizar chomp para eliminar los saltos de línea en lugar de una expresión regular de todos modos, pero le doy el beneficio de la duda y suponiendo que puede procesar entradas que contengan un estilo de saltos de línea en un entorno usa el otro estilo

[2] ... que contiene todos los nodos de las hojas, por lo que va a ser bastante grande con 200k líneas de entrada a menos que tenga árboles extremadamente angostos y profundos.

[3] ... que contiene cada línea de entrada, recortada de espacios en blanco extraños.

Answer 2

usted parece estar tratando de construir y muy-imprimir un gráfico dirigido:

#!/usr/bin/perl 

use strict; use warnings; 
use Graph::Directed; 
use Graph::TransitiveClosure::Matrix; 

my $g = Graph::Directed->new; 

while (my $line = <DATA>) { 
    next unless my ($x, $y) = split ' ', $line; 
    $g->add_edge($x, $y); 
} 

my @start = $g->source_vertices; 
my @end = $g->sink_vertices; 

my $tcm = Graph::TransitiveClosure::Matrix->new($g, 
    path_vertices => 1, 
); 

for my $s (@start) { 
    for my $e (@end) { 
     next unless $tcm->is_reachable($s, $e); 
     print join("\t", $tcm->path_vertices($s, $e)), "\n"; 
    } 
} 

__DATA__ 
S5 S3 
S5 S8 
ROOT S1 
S1 S7 
S2 S5 
S3 S4 
S1 S2 
S4 77 
S2 S9 
S3 88 

Salida:

ROOT S1  S2  S9 
ROOT S1  S2  S5  S8 
ROOT S1  S2  S5  S3  S4  77 
ROOT S1  S2  S5  S3  88 
ROOT S1  S7

No estoy seguro de si la sobrecarga de la memoria de la utilización de Graph y el cálculo de un transitive closure matrix va a ser prohibitivo en tu caso.

Answer 3

Si usted sabe lo que su nodo ROOT se llama entonces tal vez incluso un third way :)

use 5.012; 
use warnings; 

my $twigs = build_twigs_from(*DATA); 
recurse_print('ROOT', $twigs->{ROOT}); # explicit 

sub build_twigs_from { 
    my $fh = shift; 
    my %twigs; 

    while (<$fh>) { 
     $twigs{ $+{parent} }->{ $+{child} } = $twigs{ $+{child} } //= {} 
      if m/ (?<parent> \S+) \s+ (?<child> \S+) /x; 
    } 

    return \%twigs; 
} 

sub recurse_print { 
    my ($path, $child) = @_; 

    # reached end of twig? 
    unless (%$child) { 
     say $path; 
     return; 
    } 

    recurse_print($path . "\t$_", $child->{$_}) 
     for sort keys %$child; 
} 

__DATA__ 
S5 S3 
S5 S8 
ROOT S1 
S1 S7 
S2 S5 
S3 S4 
S1 S2 
S4 77 
S2 S9 
S3 88 

Lo anterior hace uso de referencias (en este caso la referencia de hash pero también podría haber sido la referencia de matriz o una mezcla de of) para vincular (es decir, alias) todos los nodos (ramas) juntos. Esto le permite mantener la clave plana (en hashref $ twigs) para cada celda y por lo tanto, cada nodo simplemente hace referencia a esto.

Si lo hace un Data::Dumper de $twigs verá esto:

$VAR1 = 
    { 
     'S1' => { 
       'S2' => { 
          'S5' => { 
            'S8' => {}, 
            'S3' => { 
               '88' => {}, 
               'S4' => { 
                 '77' => {} 
                 } 
              } 
            }, 
          'S9' => {} 
         }, 
       'S7' => {} 
       }, 
     'S9' => $VAR1->{'S1'}{'S2'}{'S9'}, 
     'S4' => $VAR1->{'S1'}{'S2'}{'S5'}{'S3'}{'S4'}, 
     'ROOT' => { 
        'S1' => $VAR1->{'S1'} 
       }, 
     'S8' => $VAR1->{'S1'}{'S2'}{'S5'}{'S8'}, 
     '88' => $VAR1->{'S1'}{'S2'}{'S5'}{'S3'}{'88'}, 
     '77' => $VAR1->{'S1'}{'S2'}{'S5'}{'S3'}{'S4'}{'77'}, 
     'S2' => $VAR1->{'S1'}{'S2'}, 
     'S5' => $VAR1->{'S1'}{'S2'}{'S5'}, 
     'S7' => $VAR1->{'S1'}{'S7'}, 
     'S3' => $VAR1->{'S1'}{'S2'}{'S5'}{'S3'} 
    }; 

que puede parecer un galimatías poco, pero si iterar a través de la tecla ROOT continuación, la jerarquía completa de referencias de hash vinculados serán expuestos (alcanzando el final de un nodo/rama cuando se trata de un hashref vacío).

Las impresiones recurse_print() subrutinas la siguiente salida de $twigs->{ROOT}:

ROOT S1 S2 S5 S3 88 
ROOT S1 S2 S5 S3 S4 77 
ROOT S1 S2 S5 S8 
ROOT S1 S2 S9 
ROOT S1 S7 

Con suerte no me he perdido algo y lo hace trabajar con sus datos 200k (Me interesaría saber cómo performant esta solución es).