Changeset 7737

Timestamp:

22/07/11 21:16:18 (10 months ago)

Author:

westram

Message:

• again added possibility to mark by acc etc. (was accidently dropped in [5767])
• added switch '-ambiguous' (allow multiple matches)
• added switch '-partial' (allow partial matches)

Files:

• trunk/PERL_SCRIPTS/SPECIES/markSpecies.pl (modified) (6 diffs)

trunk/PERL_SCRIPTS/SPECIES/markSpecies.pl

@@ -22 +22 @@
 # ------------------------------------------------------------
 
-sub markSpecies(\%$$) {
-  my ($marklist_r, $wanted_mark, $clearRest) = @_;
+sub markSpecies(\%$$$$$) {
+  my ($marklist_r, $wanted_mark, $clearRest,$field,$ambiguous,$partial) = @_;
 
   my $gb_main = ARB::open(":","rw");
@@ -32 +32 @@
   my @count = (0,0);
 
+  my %seen = ();
+  my $had_field = 0;
+
   for (my $gb_species = BIO::first_species($gb_main);
        $gb_species;
@@ -37 +40 @@
     {
       my $marked = ARB::read_flag($gb_species);
-      my $species_name = BIO::read_string($gb_species, "name");
-      $species_name || expectError('read_string');
+      my $field_content = BIO::read_string($gb_species, $field);
 
-      if (defined $$marklist_r{$species_name}) {
-        if ($marked!=$wanted_mark) {
-          ARB::write_flag($gb_species,$wanted_mark);
-          $count[$wanted_mark]++;
+      if ($field_content) {
+        $had_field++;
+
+        my $matching_entry = undef;
+
+        if (defined $$marklist_r{$field_content}) {
+          $matching_entry = $field_content;
         }
-        delete $$marklist_r{$species_name};
-      }
-      else {
-        if ($marked==$wanted_mark and $clearRest==1) {
-          ARB::write_flag($gb_species,1-$wanted_mark);
-          $count[1-$wanted_mark]++;
+        else {
+        MATCH: foreach (keys %$marklist_r) {
+            if ($field_content =~ /$_/) {
+              $matching_entry = $_;
+              last MATCH;
+            }
+          }
+        }
+
+        if (defined $matching_entry) {
+          if ($marked!=$wanted_mark) {
+            ARB::write_flag($gb_species,$wanted_mark);
+            $count[$wanted_mark]++;
+          }
+          if ($ambiguous==1) {
+            $seen{$matching_entry} = 1;
+          }
+          else {
+            # expect field content to be unique
+            # -> delete after use
+            delete $$marklist_r{$matching_entry};
+          }
+        }
+        else {
+          if ($marked==$wanted_mark and $clearRest==1) {
+            ARB::write_flag($gb_species,1-$wanted_mark);
+            $count[1-$wanted_mark]++;
+          }
         }
       }
     }
 
+  if ($ambiguous==1) {
+    # correct marklist
+    foreach (keys %seen) { delete $$marklist_r{$_}; }
+  }
+
   ARB::commit_transaction($gb_main);
   ARB::close($gb_main);
+
+  if ($had_field==0) { die "No species has a field named '$field'\n"; }
 
   return ($count[1],$count[0]);
@@ -85 +119 @@
   my ($err) = @_;
   print "Purpose: Mark/unmark species in running ARB\n";
-  print "Usage: markSpecies.pl [-unmark] [-keep] specieslist\n";
-  print "       -unmark   Unmark species (default is to mark)\n";
-  print "       -keep     Do not change rest (default is to unmark/mark rest)\n";
+  print "Usage: markSpecies.pl [-unmark] [-keep] specieslist [field]\n";
+  print "       -unmark     Unmark species (default is to mark)\n";
+  print "       -keep       Do not change rest (default is to unmark/mark rest)\n";
+  print "       -ambiguous  Allow field to be ambiguous (otherwise it has to be unique)\n";
+  print "       -partial    Allow partial match for field content (slow!)\n";
   print "\n";
-  print "specieslist is a file containing one species per line\n";
+  print "specieslist is a file containing one entry per line\n";
+  print "   normally the entry will be the short name as used in your DB\n";
+  print "   when you specify 'field' you may use other entries (e.g. 'acc')\n";
+  print "\n";
   print "Use '-' as filename to read from STDIN\n";
   print "\n";
@@ -101 +140 @@
   my $mark      = 1;
   my $clearRest = 1;
+  my $ambiguous = 0;
+  my $partial   = 0;
 
-  while ($args>1) {
+  while (substr($ARGV[0],0,1) eq '-') {
     my $arg = shift @ARGV;
     if ($arg eq '-unmark') { $mark = 0; }
     elsif ($arg eq '-keep') { $clearRest = 0; }
+    elsif ($arg eq '-ambiguous') { $ambiguous = 1; }
+    elsif ($arg eq '-partial') { $partial = 1; }
     else { die_usage("Unknown switch '$arg'"); }
     $args--;
   }
 
-  my $file = shift @ARGV;
+  my $file  = shift @ARGV;
+  my $field = shift @ARGV;
+  $field = 'name' if (not defined $field);
+
   my %marklist;
   buildMarklist($file,%marklist);
-  my ($marked,$unmarked) = markSpecies(%marklist,$mark,$clearRest);
+  my ($marked,$unmarked) = markSpecies(%marklist,$mark,$clearRest,$field,$ambiguous,$partial);
 
   if ($marked>0) { print "Marked $marked species\n"; }
@@ -120 +166 @@
   my @notFound = keys %marklist;
   if (scalar(@notFound)) {
-    print "Some species were not found in database:\n";
+    if ($field eq 'name') {
+      print "Some species were not found in database:\n";
+    }
+    else {
+      print "Some entries did not match any species:\n";
+    }
     foreach (@notFound) { print "- '$_'\n"; }
   }