source: branches/profile/PERL_SCRIPTS/ARBTOOLS/import_from_table.pl

Last change on this file was 12442, checked in by westram, 5 years ago
  • remove rest of non-unix LFs (trailing \r's)
  • Property svn:executable set to *
File size: 10.4 KB
Line 
1#!/usr/bin/perl
2# =============================================================== #
3#                                                                 #
4#   File      : import_from_table.pl                              #
5#   Purpose   : import data from comma- or tab-separated tables   #
6#                                                                 #
7#   Coded by Ralf Westram (coder@reallysoft.de) in January 2011   #
8#   Institute of Microbiology (Technical University Munich)       #
9#   http://www.arb-home.de/                                       #
10#                                                                 #
11# =============================================================== #
12
13use strict;
14use warnings;
15
16BEGIN {
17  if (not exists $ENV{'ARBHOME'}) { die "Environment variable \$ARBHOME has to be defined"; }
18  my $arbhome = $ENV{'ARBHOME'};
19  push @INC, "$arbhome/lib";
20  push @INC, "$arbhome/PERL_SCRIPTS/lib";
21  1;
22}
23
24use ARB;
25use tools;
26
27sub usage($) {
28  my ($error) = @_;
29  print(
30        "Usage: perl import_from_table.pl --match CF --write CF [options] datafile [database outdb]\n".
31        "\n".
32        "Imports one column from the calc-sheet 'datafile' into an ARB database.\n".
33        "\n".
34        "'datafile'     should be a list of tab-separated values.\n".
35        "'database'     if a name is specified, the modified DB will be saved as 'outdb'.\n".
36        "               Otherwise the database running in ARB will be modified.\n".
37        "\n".
38        "--match CF     CF:=column,field\n".
39        "               Define a 'column' in the 'datafile' and a species-'field' in the database.\n".
40        "               For each row the content of the 'column' has to match the content of the\b".
41        "               'field' for exactly one species in the 'database'.\n".
42        "               Useful fields are 'acc' and 'name'.\n".
43        "--write CF     CF:=column,field\n".
44        "               For each row in 'datafile' write the content of 'column' into the\n".
45        "               'field' of the species matched via --match\n".
46        "\n".
47        "Available 'options':\n".
48        "--csv            expect 'datafile' is a list of comma-separated values (default: TAB-separated)\n".
49        "--overwrite      overwrite 'field' specified via --write (default: abort if 'field' exists)\n".
50        "--skip-unknown   silently skip rows that don't match any species (default: abort if no match found)\n".
51        "--marked-only    only write to marked species (default: all species)\n".
52        "--mark           mark species to which field has been imported (unmarks rest)\n".
53        "--as-integer     use INTEGER database-type for field (default: STRING)\n"
54       );
55
56  if (defined $error) {
57    die "\nError: $error";
58  }
59}
60
61sub max($$) { my ($a,$b) = @_; return $a<$b ? $b : $a; }
62
63sub parse_CF($$) {
64  my ($switch,$CF) = @_;
65  my ($column,$field);
66  eval {
67    if ($CF =~ /^([^,]+),(.*)$/o) {
68      ($column,$field) = ($1,$2);
69      my $int_column = int($column);
70      if ($int_column<1) { die "'$column' is not a valid column\n"; }
71      my $error = ARB::check_key($field);
72      if (defined $error) { die "'$field' is not a valid DB field name\n"; }
73    }
74    else { die "',' expected in '$CF'\n"; }
75  };
76  if ($@) { die "in '$switch $CF': $@\n"; }
77  return ($column,$field);
78}
79
80my $reg_column1 = undef;
81my $reg_column2 = undef;
82
83sub set_separator($) {
84  my ($sep) = @_;
85  my $rex1 = "^([^$sep\"]+)$sep"; # plain column
86  my $rex2 = "^\"([^\"]+)\"$sep"; # quoted column
87  $reg_column1 = qr/$rex1/;
88  $reg_column2 = qr/$rex2/;
89}
90
91sub parse_row($\@) {
92  my ($line,$column_r) = @_;
93  @$column_r = ();
94  while (($line =~ $reg_column1) or ($line =~ $reg_column2)) {
95    my ($col,$rest) = ($1,$');
96    push @$column_r, $col;
97    $line = $rest;
98  }
99  push @$column_r, $line;
100}
101
102my $inform_ARB = 0;
103sub main() {
104  my $datafile;
105  my $database     = ':';
106  my $database_out;
107
108  my ($matchcolumn,$matchfield);
109  my ($writecolumn,$writefield);
110  my ($skip_unknown,$overwrite,$marked_only,$mark) = (0,0,0,0);
111  my $int_type = 0;
112
113  my @no_option = ();
114
115  set_separator("\t");
116
117  eval {
118    while (scalar(@ARGV)>0) {
119      my $arg = shift @ARGV;
120      if    ($arg eq '--match') { ($matchcolumn,$matchfield) = parse_CF($arg, shift @ARGV); }
121      elsif ($arg eq '--write') { ($writecolumn,$writefield) = parse_CF($arg, shift @ARGV); }
122      elsif ($arg eq '--csv') { set_separator(','); }
123      elsif ($arg eq '--overwrite') { $overwrite = 1; }
124      elsif ($arg eq '--skip-unknown') { $skip_unknown = 1; }
125      elsif ($arg eq '--marked-only') { $marked_only = 1; }
126      elsif ($arg eq '--mark') { $mark = 1; }
127      elsif ($arg eq '--as-integer') { $int_type = 1; }
128      else { push @no_option, $arg; }
129    }
130
131    $datafile = shift @no_option;
132    if (not defined $datafile) { die "Missing argument 'datafile'\n"; }
133    if ($datafile =~ /^--/) { die "Unknown switch '$datafile'\n"; }
134
135    if (scalar(@no_option)) {
136      $database     = shift @no_option;
137      $database_out = shift @no_option;
138      if (not defined $database_out) { die "Missing argument 'outdb'\n"; }
139    }
140
141    if (scalar(@no_option)) { die "Unexpected arguments: ".join(',', @no_option)."\n"; }
142
143    if (not defined $matchcolumn) { die "Mandatory option '--match CF' missing\n"; }
144    if (not defined $writecolumn) { die "Mandatory option '--write CF' missing\n"; }
145  };
146  if ($@) {
147    usage($@);
148  }
149
150  my $gb_main = ARB::open($database, "rw");
151  if ($database eq ':') {
152    if ($gb_main) { $inform_ARB = 1; }
153    else { expectError('db connect (no running ARB)'); }
154  }
155  else {
156    $gb_main || expectError('db connect (wrong \'database\' specified?)');
157  }
158
159  if (not -f $datafile) { die "No such file '$datafile'\n"; }
160  open(TABLE,'<'.$datafile) || die "can't open '$datafile' (Reason: $!)\n";
161
162  my %write_table = (); # key=matchvalue, value=writevalue
163  my %source_line = (); # key=matchvalue, value=source-linenumber
164
165  eval {
166    my $min_elems = max($matchcolumn,$writecolumn);
167    my $line;
168    while (defined($line=<TABLE>)) {
169      eval {
170        chomp $line;
171        $line =~ s/\r+$//;
172        my @row = ();
173        parse_row($line,@row);
174
175        my $relems = scalar(@row);
176        if ($relems<$min_elems) {
177          die "need at least $min_elems columns per table-line\n".
178            "(seen only $relems column. Maybe wrong separator chosen?)\n";
179        }
180
181        my $matchvalue = $row[$matchcolumn-1];
182        my $writevalue = $row[$writecolumn-1];
183
184        if (exists $write_table{$matchvalue}) {
185          die "duplicated value '$matchvalue' in column $matchcolumn (first seen in line ".$source_line{$matchvalue}.")\n";
186        }
187        $write_table{$matchvalue} = $writevalue;
188        $source_line{$matchvalue} = $.;
189      };
190      if ($@) { die "in line $. of '$datafile': $@"; }
191    }
192
193    # match and write to species
194    dieOnError(ARB::begin_transaction($gb_main), 'begin_transaction');
195
196    my $report = '';
197
198    eval {
199      my %written = (); # key=matchvalue, value: 1=written, 2=skipped cause not marked
200      for (my $gb_species = BIO::first_species($gb_main);
201           $gb_species;
202           $gb_species = BIO::next_species($gb_species)) {
203        eval {
204          my $species_value = BIO::read_as_string($gb_species, $matchfield);
205          my $wanted_mark = 0;
206          if ($species_value) {
207            if (exists $write_table{$species_value}) { # found species matching table entry
208              if ($marked_only==1 and ARB::read_flag($gb_species)==0) {
209                $written{$species_value} = 2;
210              }
211              else {
212                my $existing_entry = BIO::read_as_string($gb_species, $writefield);
213                if ($existing_entry and not $overwrite) {
214                  die "already has an existing field '$writefield'.\n".
215                    "Use --overwrite to allow replacement.\n";
216                }
217                my $error = undef;
218                if ($int_type==1) {
219                  $error = BIO::write_int($gb_species, $writefield, int($write_table{$species_value}));
220                }
221                else {
222                  $error = BIO::write_string($gb_species, $writefield, $write_table{$species_value});
223                }
224                if ($error) { die $error; }
225                $wanted_mark = 1;
226                $written{$species_value} = 1;
227              }
228            }
229          }
230          else {
231            die "No such DB-entry '$matchfield'\n";
232          }
233          if ($mark==1) {
234            my $error = ARB::write_flag($gb_species,$wanted_mark);
235            if ($error) { die $error; }
236          }
237        };
238        if ($@) {
239          my $name = BIO::read_name($gb_species);
240          die "species '$name': $@";
241        }
242      }
243      my $not_found  = 0;
244      my $not_marked = 0;
245      {
246        my %missing = ();
247        my $what = $skip_unknown ? 'Warning' : 'Error';
248        foreach (keys %write_table) {
249          my $wr = $written{$_};
250          if (not defined $wr) {
251            $missing{$_} = 1;
252            $not_found++;
253          }
254          elsif ($wr==2) { # was not marked
255            $not_marked++;
256          }
257        }
258        foreach (sort { $source_line{$a} <=> $source_line{$b}; } keys %missing) {
259          print "$what: Found no matching species for line ".$source_line{$_}." ($matchfield='$_')\n";
260        }
261      }
262      if ($not_found>0 and $skip_unknown==0) {
263        die "Failed to find $not_found species - aborting.\n".
264          "(Note: use --skip-unknown to allow unknown references)\n";
265      }
266      $report = "Entries imported: ".(scalar(keys %written)-$not_marked)."\n";
267      if ($not_found>0) { $report .= "Unmatched (skipped) entries: $not_found\n"; }
268      if ($not_marked>0) { $report .= "Entries not imported because species were not marked: $not_marked\n"; }
269
270      print "\n".$report;
271    };
272    if ($@) {
273      ARB::abort_transaction($gb_main);
274      die $@;
275    }
276    ARB::commit_transaction($gb_main);
277    if ($database ne ':') { # database has been loaded
278      print "Saving modified database to '$database_out'\n";
279      my $error = ARB::save_as($gb_main, $database_out, "b");
280      if ($error) { die $error; }
281    }
282    ARB::close($gb_main);
283
284    if ($inform_ARB==1) {
285      $report =~ s/\n$//;
286      `arb_message "$report"`;
287    }
288  };
289  if ($@) {
290    ARB::close($gb_main);
291    die $@;
292  }
293  close(TABLE);
294}
295
296eval {
297  main();
298};
299if ($@) {
300  my $error = "Error in import_from_table.pl: $@";
301  print $error;
302  if ($inform_ARB==1) {
303    $error =~ s/: /:\n/g;       # wrap error to multiple lines for ARB
304    `arb_message "$error";`;
305  }
306  exit(-1);
307}
308exit(0);
Note: See TracBrowser for help on using the repository browser.