help script perl comparaison de deux fichiers

Version imprimable

Voir 40 message(s) de cette discussion en une page

Dans ce cas, laisse XX dans la fonction merge_cols, et post-traite le après l'appel en remplaçant

Code:

1
2
merge_cols(...);
warn "Different homo/homo or hetero/hetero at line $. in\n$line\n" if grep $_ eq "XX" values %$columns;

par

Code:

1
2
3
4
5
merge_cols(...);
foreach my $invalid (grep $_ eq "XX", values %$columns) {
  warn "Different homo/homo or hetero/hetero at line $. in\n$line\n";
  $invalid = "--";
}

je sais pas si je l'ai copié au bon endroit mais j'ai une erreur...

cplantar@sxsmp01:~/perl> perl compa4.pl
Global symbol "$columns" requires explicit package name at compa4.pl line 29.
Global symbol "$line" requires explicit package name at compa4.pl line 30.
Execution of compa4.pl aborted due to compilation errors.
cplantar@sxsmp01:~/perl>

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
#!/usr/bin/perl
 
#!/usr/local/bin/perl -w
 
 
############################################################################################
#
#
# Script pour créer une matrice de genotypage realisant la synthèse de 2 matrices différentes
#
# usage: perl ./ 	trois fichier (a renommer avant le lancement du script
#					-fic1.txt (premiere matrice de données)
#					-fic2.txt (deuxieme matrice de données)
#					-fic3.txt (troisieme matrice genere le resultat voulu)
#
# en sortie: une matrice de synthèse
#
# creation: 08/03/2012- Cyril Plantard
#
############################################################################################
 
use strict;
use warnings;
use feature qw(:5.10);
 
use List::MoreUtils qw(each_array);
 
sub merge_cols(\@\@$) {
foreach my $invalid (grep $_ eq "XX", values %$columns) {
  warn "Different homo/homo or hetero/hetero at line $. in\n$line\n";
  $invalid = "--";
}
 
  my ($col_names, $col_values, $columns) = @_;
 
  my $col_index = 0;
  foreach my $col_value (@$col_values) {
    my $col_name = $col_names->[$col_index++];
 
    if (!exists $columns->{$col_name}) {
      # ajoute une nouvelle colonne
      $columns->{$col_name} = $col_value;
    }
    else {
      my $existing_col = $columns->{$col_name};
 
      if ($existing_col eq "--" || $col_value eq "--") {
        my $value = $existing_col eq "--" ? $col_value : $existing_col;
        # Choisissez le courant col si présentent déjà à la ligne actuelle
        $columns->{$col_name} = (grep $_ eq $value, values %{$columns}) ? $col_value : "--";
      }
      else {
        # selectionne le dominant
        my %cur_char = map { $_ => 1 } split //, $existing_col;
        my %new_char = map { $_ => 1 } split //, $col_value;
        my $char_cmp = keys %cur_char <=> keys %new_char;
        $columns->{$col_name} = $char_cmp < 0 ? $existing_col : $char_cmp > 0 ? $col_value :
          $existing_col eq $col_value ? $col_value : "XX";
 
 
      }
    }
  }
}
 
sub load_table {
  my ($result_tabref, $result_keyref, $file) = @_;
 
  open my $TABLE, "<", $file or die "Can't open $file: $!";
  chomp(my $line = <$TABLE>);
  my ($test_key, @col_names) = split /\s+/, $line;
  if (!@$result_tabref) {
    # Créez la première rangée contenant une clé de test et un hash de noms de colonne
    my $column_number = 1;
    push @$result_tabref, [ $test_key, { map { $_ => $column_number++ } @col_names } ];
  }
  else {
    # complete la premiere colonne
    my $columns = $result_tabref->[0]->[1];
    my $column_number = 1 + keys %$columns;
    $columns->{$_} = $column_number++ foreach grep !exists $columns->{$_}, @col_names;
  }
 
  #my $col_number = keys %{$result_tabref->[0]->[1]};
  while (defined($line = <$TABLE>)) {
    chomp $line;
    my ($test_key, @col_values) = split /\s+/, $line;
    if (exists $result_keyref->{$test_key}) {
      # Compléte une rangée existante
      my $columns = $result_tabref->[$result_keyref->{$test_key}]->[1];
      my $col_index = 0;
      merge_cols(@col_names, @col_values, $columns);
    }
    else {
      # Créez une liste de valeurs de colonne manquantes (du numéro de colonne de la première rangée)
      my $col_index = 0;
      push @$result_tabref, [ $test_key, { map { $col_names[$col_index++] => $_ } @col_values } ];
      $result_keyref->{$test_key} = $#$result_tabref;
    }
  }
}
 
sub print_table {
  my ($tabref, $file) = @_;
 
  open my $OUT, ">", $file or die "Can't open $file: $!";
 
  # la rangée contient des noms de colonne et les positions
  my ($first_col, $col_names) = @{shift @$tabref};
  my @col_names = sort { $col_names->{$a} cmp $col_names->{$b} } keys %$col_names;
  say { $OUT } join " ", $first_col, @col_names;
 
  foreach my $row (@$tabref) {
    #  la rangée contient des noms de colonne et les positions
    my ($test_key, $col_values) = @$row;
    say { $OUT } join " ", $test_key, map $col_values->{$_} // "--", @col_names;
  }
}
 
# telechargement des deux fichiers fic1.txt et fic2.txt
my (@table, %test_keys);
load_table(\@table, \%test_keys, "fic1.txt");
load_table(\@table, \%test_keys, "fic2.txt");
# ecriture du fichier final fic3.txt
print_table(\@table, "fic3.txt");

20/03/2012, 09h25
Philou67430
Tu dois déplacer ces lignes
Code:

1 2 3 4 foreach my $invalid (grep $_ eq "XX", values %$columns) { warn "Different homo/homo or hetero/hetero at line $. in\n$line\n"; $invalid = "--"; }
après la ligne 92

Code:

merge_cols(@col_names, @col_values, $columns);

Ainsi, dans merge_cols, tu gardes encore la différentiation entre -- et XX, puis tu traites tous les XX pour les remplacer en --, et le signaler avec une warning sur l'erreur standard STDERR.
20/03/2012, 09h41
nosuperman

il m'affiche bien quelque choses dans le terminal mais il m'affiche toutes une lignée et on voit pas réellement ou est ce qui a eu

dans le fic1 et le fic2 deux hommo différent parce qui a pas les nom qui s'affiche... juste le code bs et toute la ligne
20/03/2012, 11h33
Philou67430

Bah... tu ne m'as pas spécifié précisément ce que tu voulais voir apparaitre, et je ne suis pas devin ;)

Précise donc, et donne un exemple...
20/03/2012, 11h59
nosuperman

fic1
test philou cyril clotilde
sb001 AA AA AA
sb002 AB AB AB

fic2
test philou cyril clotilde
sb001 BB AA AA
sb002 AB BA AB

j'aimerais un fichier log qui me dise
attention pour philou pour la sb001 dans le fichier un y avais AA et dans le fichier 2 y avais BB
(cas ou y a deux homo different)
et pour le cas etero etero pareil
attention pour cyril pour la sb002 y avais AB et dans le fichier 2 y avais BA

c'est possible? or not
20/03/2012, 13h45
Philou67430

Comme dit, tout est toujours possible, tout dépend des moyens qu'on y mets.

Je planche quelques minutes et je reviens :)

Voila un script complet :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
#!/usr/bin/perl
 
use strict;
use warnings;
use feature qw(:5.10);
 
use List::MoreUtils qw(indexes);
 
sub merge_cols(\@\@$) {
  my ($col_names, $col_values, $columns) = @_;
 
  my $col_index = 0;
  foreach my $col_value (@$col_values) {
    my $col_name = $col_names->[$col_index++];
 
    if (!exists $columns->{$col_name}) {
      # add a new column
      $columns->{$col_name} = $col_value;
    }
    else {
      my $existing_col = $columns->{$col_name};
 
      if ($existing_col eq "--" || $col_value eq "--") {
        my $value = $existing_col eq "--" ? $col_value : $existing_col;
        # select current col if already present in the current line
        $columns->{$col_name} = (grep $_ eq $value, values %{$columns}) ? $col_value : "--";
      }
      else {
        # select the dominant
        my %cur_char = map { $_ => 1 } split //, $existing_col;
        my %new_char = map { $_ => 1 } split //, $col_value;
        my $char_cmp = keys %cur_char <=> keys %new_char;
        $columns->{$col_name} = $char_cmp < 0 ? $existing_col : $char_cmp > 0 ? $col_value :
          $existing_col eq $col_value ? $col_value : "XX($existing_col)";
      }
    }
  }
}
 
sub load_table {
  my ($result_tabref, $result_keyref, $file) = @_;
 
  say "Loading file $file";
  open my $TABLE, "<", $file or die "Can't open $file: $!";
  chomp(my $line = <$TABLE>);
  my ($test_key, @col_names) = split /\s+/, $line;
  if (!@$result_tabref) {
    # create the first row containing a test key and a hash of column names
    my $column_number = 1;
    push @$result_tabref, [ $test_key, { map { $_ => $column_number++ } @col_names } ];
  }
  else {
    # complete the first row
    my $columns = $result_tabref->[0]->[1];
    my $column_number = 1 + keys %$columns;
    $columns->{$_} = $column_number++ foreach grep !exists $columns->{$_}, @col_names;
  }
 
  #my $col_number = keys %{$result_tabref->[0]->[1]};
  while (defined($line = <$TABLE>)) {
    chomp $line;
    my ($test_key, @col_values) = split /\s+/, $line;
    if (exists $result_keyref->{$test_key}) {
      # complete an existing row
      my $columns = $result_tabref->[$result_keyref->{$test_key}]->[1];
      my $col_index = 0;
      merge_cols(@col_names, @col_values, $columns);
      foreach my $invalid (grep { $columns->{$_} =~ "XX" } keys %$columns) {
        my ($invalid_col) = indexes { $_ eq $invalid } @col_names;
        my ($current_col) = $columns->{$invalid} =~ /\(([^\)]+)\)/;
        warn "WARNING: for $invalid at line $test_key, current file contains $current_col and $file contains $col_values[$invalid_col]\n";
        $columns->{$invalid} = "--";
      }
    }
    else {
      # create a list of missing column values (from the column number of the first row)
      my $col_index = 0;
      push @$result_tabref, [ $test_key, { map { $col_names[$col_index++] => $_ } @col_values } ];
      $result_keyref->{$test_key} = $#$result_tabref;
    }
  }
}
 
sub print_table {
  my ($tabref, $file) = @_;
 
  open my $OUT, ">", $file or die "Can't open $file: $!";
 
  # First row contains column names and positions ($other_cols is a hash)
  my ($first_col, $col_names) = @{shift @$tabref};
  my @col_names = sort { $col_names->{$a} cmp $col_names->{$b} } keys %$col_names;
  say { $OUT } join " ", $first_col, @col_names;
 
  foreach my $row (@$tabref) {
    # First row contains column names and positions ($col_values is a hash)
    my ($test_key, $col_values) = @$row;
    say { $OUT } join " ", $test_key, map $col_values->{$_} // "--", @col_names;
  }
}
 
my (@table, %test_keys);
load_table(\@table, \%test_keys, "fic1.txt");
load_table(\@table, \%test_keys, "fic2.txt");
print_table(\@table, "fic3.txt");

20/03/2012, 15h38
nosuperman

super :) et si on veut copier le resultat dans un fichier txt?
j'ai essayé perl compa.pl > erreur.txt
ca marche pas...
20/03/2012, 16h36
Philou67430

Soit tu ouvres un nouveau fichier (open my $ERR, ">", ...) et tu écris dedans (print { $ERR }) au lieu de faire warn.

Soit tu appelles le script en redirigeant la sortie STDERR au lieu de la sortie STDOUT :

Code:

perl compa.pl 2> erreur.txt
21/03/2012, 08h44
nosuperman

merci vraiment philou avant de mettre resolu y aura un test final dans la semaine avec toutes l'equipes... voila
21/03/2012, 09h11
Philou67430

J'espère bien ... j'ai fait sans en toute ignorance de cause... il y a forcément des informations "biologiques" qui me manquent, et par conséquent, des bugs potentiels sur les résultats.

Voir 40 message(s) de cette discussion en une page