source: trunk/PERL_SCRIPTS/SPECIES/markSpecies.pl

Last change on this file was 12442, checked in by westram, 6 years ago
  • remove rest of non-unix LFs (trailing \r's)
  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 4.8 KB
Line 
1#! /usr/bin/perl
2
3#############################################################################
4# Harald Meier (meierh@in.tum.de); 2006 LRR, Technische Universität München #
5#############################################################################
6
7use strict;
8use warnings;
9# use diagnostics;
10
11BEGIN {
12  if (not exists $ENV{'ARBHOME'}) { die "Environment variable \$ARBHOME has to be defined"; }
13  my $arbhome = $ENV{'ARBHOME'};
14  push @INC, "$arbhome/lib";
15  push @INC, "$arbhome/PERL_SCRIPTS/lib";
16  1;
17}
18
19use ARB;
20use tools;
21
22# ------------------------------------------------------------
23
24sub markSpecies(\%$$$$$) {
25  my ($marklist_r, $wanted_mark, $clearRest,$field,$ambiguous,$partial) = @_;
26
27  my $gb_main = ARB::open(":","rw");
28  $gb_main || expectError('db connect (no running ARB?)');
29
30  dieOnError(ARB::begin_transaction($gb_main), 'begin_transaction');
31
32  my @count = (0,0);
33
34  my %seen = ();
35  my $had_field = 0;
36
37  for (my $gb_species = BIO::first_species($gb_main);
38       $gb_species;
39       $gb_species = BIO::next_species($gb_species))
40    {
41      my $marked = ARB::read_flag($gb_species);
42      my $field_content = BIO::read_string($gb_species, $field);
43
44      if ($field_content) {
45        $had_field++;
46
47        my $matching_entry = undef;
48
49        if (defined $$marklist_r{$field_content}) {
50          $matching_entry = $field_content;
51        }
52        else {
53        MATCH: foreach (keys %$marklist_r) {
54            if ($field_content =~ /$_/) {
55              $matching_entry = $_;
56              last MATCH;
57            }
58          }
59        }
60
61        if (defined $matching_entry) {
62          if ($marked!=$wanted_mark) {
63            ARB::write_flag($gb_species,$wanted_mark);
64            $count[$wanted_mark]++;
65          }
66          if ($ambiguous==1) {
67            $seen{$matching_entry} = 1;
68          }
69          else {
70            # expect field content to be unique
71            # -> delete after use
72            delete $$marklist_r{$matching_entry};
73          }
74        }
75        else {
76          if ($marked==$wanted_mark and $clearRest==1) {
77            ARB::write_flag($gb_species,1-$wanted_mark);
78            $count[1-$wanted_mark]++;
79          }
80        }
81      }
82    }
83
84  if ($ambiguous==1) {
85    # correct marklist
86    foreach (keys %seen) { delete $$marklist_r{$_}; }
87  }
88
89  ARB::commit_transaction($gb_main);
90  ARB::close($gb_main);
91
92  if ($had_field==0) { die "No species has a field named '$field'\n"; }
93
94  return ($count[1],$count[0]);
95}
96
97sub buildMarklist($\%) {
98  my ($file,$marklist_r) = @_;
99
100  my @lines;
101  if ($file eq '-') { # use STDIN
102    @lines = <STDIN>;
103  }
104  else {
105    open(FILE,'<'.$file) || die "can't open '$file' (Reason: $!)";
106    @lines = <FILE>;
107    close(FILE);
108  }
109
110  %$marklist_r = map {
111    chomp;
112    s/\r+$//;
113    $_ => 1;
114  } @lines;
115}
116
117# ------------------------------------------------------------
118
119sub die_usage($) {
120  my ($err) = @_;
121  print "Purpose: Mark/unmark species in running ARB\n";
122  print "Usage: markSpecies.pl [-unmark] [-keep] specieslist [field]\n";
123  print "       -unmark     Unmark species (default is to mark)\n";
124  print "       -keep       Do not change rest (default is to unmark/mark rest)\n";
125  print "       -ambiguous  Allow field to be ambiguous (otherwise it has to be unique)\n";
126  print "       -partial    Allow partial match for field content (slow!)\n";
127  print "\n";
128  print "specieslist is a file containing one entry per line\n";
129  print "   normally the entry will be the species ID (shortname) as used in your DB\n";
130  print "   when you specify 'field' you may use other entries (e.g. 'acc')\n";
131  print "\n";
132  print "Use '-' as filename to read from STDIN\n";
133  print "\n";
134  die "Error: $err\n";
135}
136
137sub main() {
138  my $args = scalar(@ARGV);
139  if ($args<1) { die_usage('Missing arguments'); }
140
141  my $mark      = 1;
142  my $clearRest = 1;
143  my $ambiguous = 0;
144  my $partial   = 0;
145
146  while (substr($ARGV[0],0,1) eq '-') {
147    my $arg = shift @ARGV;
148    if ($arg eq '-unmark') { $mark = 0; }
149    elsif ($arg eq '-keep') { $clearRest = 0; }
150    elsif ($arg eq '-ambiguous') { $ambiguous = 1; }
151    elsif ($arg eq '-partial') { $partial = 1; }
152    else { die_usage("Unknown switch '$arg'"); }
153    $args--;
154  }
155
156  my $file  = shift @ARGV;
157  my $field = shift @ARGV;
158  $field = 'name' if (not defined $field);
159
160  my %marklist;
161  buildMarklist($file,%marklist);
162  my ($marked,$unmarked) = markSpecies(%marklist,$mark,$clearRest,$field,$ambiguous,$partial);
163
164  if ($marked>0) { print "Marked $marked species\n"; }
165  if ($unmarked>0) { print "Unmarked $unmarked species\n"; }
166
167  my @notFound = keys %marklist;
168  if (scalar(@notFound)) {
169    if ($field eq 'name') {
170      print "Some species were not found in database:\n";
171    }
172    else {
173      print "Some entries did not match any species:\n";
174    }
175    foreach (@notFound) { print "- '$_'\n"; }
176  }
177}
178
179main();
180
Note: See TracBrowser for help on using the repository browser.