[Bio] / FigKernelPackages / Subsystem.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.24, Mon Aug 16 22:10:55 2004 UTC revision 1.25, Thu Aug 26 21:26:52 2004 UTC
# Line 1  Line 1 
1    
2  package Subsystem;  package Subsystem;
3    
4    use Carp;
5  use FIG;  use FIG;
6    
7  use FIGAttributes;  use FIGAttributes;
# Line 25  Line 26 
26  canonical version of the subsystem information in the flat-files  canonical version of the subsystem information in the flat-files
27  kept in $FIG_Config::data/Subsystems.  kept in $FIG_Config::data/Subsystems.
28    
29    =head2 Objects.
30    
31    We define the following perl objects:
32    
33    Subsystem: represents a subsystem. It can be read from disk and
34    written to disk, and manipulated via its methods when in memory.
35    
36    If we were completely on the OO side of the world, we would also
37    define the following set of objects. However, we are not, so they are
38    only objects in a conceptual sense. They are implemented using the
39    basic perl datatypes.
40    
41    Role: represents a single role. A role has a name and an abbreviation.
42    
43    RoleSubset: represents a subset of available roles. A subset has a
44    name and a list of role names that comprise the subset.
45    
46  =head2 Thoughts on locking  =head2 Thoughts on locking
47    
48  It is currently dangerous for multiple users to modify spreadsheets at once.  It is currently dangerous for multiple users to modify spreadsheets at once.
# Line 62  Line 80 
80    
81  1 if subsystem is exchangable, 0 otherwise.  1 if subsystem is exchangable, 0 otherwise.
82    
   
83  =item roles  =item roles
84    
85  list of role names  List of role names.
86    
87  =item role_index  =item role_index
88    
# Line 97  Line 114 
114    
115  =item genome  =item genome
116    
117  List (1-indexed, so element 0 is undef) of genome IDs.  List  of genome IDs.
118    
119  =item variant_code  =item variant_code
120    
121  List (1-indexed, so element 0 is undef) of variant codes.  List of variant codes.
122    
123  =item genome_index  =item genome_index
124    
125  Hash mapping from genome ID to genome index.  Hash mapping from genome ID to genome index.
126    
 =item variant_code  
   
 List (1-indexed, so element 0 is undef) of variant codes.  
   
127  =item spreadsheet  =item spreadsheet
128    
129  Spreadsheet data. Structured as a list of rows, each of  which  Spreadsheet data. Structured as a list of rows, each of  which
# Line 123  Line 136 
136    
137  =back  =back
138    
139    =head2  Methods
140    
141    =over 4
142    
143    =item index_cell
144    
145    Create the subsystem_index entries for the given cell.
146    (NEW).
147    
148    =item delete_role(name)
149    
150    Delete the given role.
151    
152    =item add_role(name, abbr)
153    
154    Add a new role.
155    
156    =item get_subset(name)
157    
158    Returns a given subset. A subset is an object, implemented as a blessed array
159    of roles.
160    
161    =item add_genome(genome_id, variant_code)
162    
163    =item remove_genome(genome_id)
164    
165    =back
166    
167  =cut  =cut
168    
169  =pod  =pod
# Line 146  Line 187 
187      # For loading, the subsystem directory must already exist.      # For loading, the subsystem directory must already exist.
188      #      #
189    
190      if (! -d $ssa_dir)      if (! -d $ssa_dir and not $create)
     {  
         if ($create)  
         {  
             return create_subsystem($class, $name, $fig);  
         }  
         else  
191          {          {
192  #           warn "Subsystem $name does not exist\n";  #           warn "Subsystem $name does not exist\n";
193              return undef;              return undef;
194          }          }
     }  
195    
196      my $self = {      my $self = {
197          dir => $ssa_dir,          dir => $ssa_dir,
# Line 167  Line 201 
201    
202      bless($self, $class);      bless($self, $class);
203    
204        if ($create)
205        {
206            $self->create_subsystem();
207        }
208        else
209        {
210      $self->load();      $self->load();
211        }
212    
213      return $self;      return $self;
214  }  }
# Line 196  Line 237 
237      return $self;      return $self;
238  }  }
239    
240    =pod
241    
242    =head2 create_subsystem()
243    
244    Create a new subsystem. This creates the subsystem directory in the
245    correct place ($FIG_Config::data/Subsystems), and populates it with
246    the correct initial data.
247    
248    =cut
249    
250  sub create_subsystem  sub create_subsystem
251  {  {
252      my($class, $name, $fig) = @_;      my($self) = @_;
253    
254      return undef;      my $dir = $self->{dir};
255        my $fig = $self->{fig};
256    
257        if (-d $dir)
258        {
259            warn "Not creating: Subsystem directory $dir already exists";
260            return;
261        }
262    
263        $fig->verify_dir($dir);
264    
265        #
266        # Initialize empty data structures.
267        #
268    
269        $self->{genome} = [];
270        $self->{genome_index} = {};
271        $self->{variant_code} = [];
272    
273        $self->{abbr} = {};
274        $self->{role_index} = {};
275        $self->{roles} = [];
276        $self->{role_abbrs} = [];
277    
278        $self->{spreadsheet} = [];
279        $self->{spreadsheet_inv} = [];
280    
281        $self->{col_subsets} = [];
282        $self->{col_subset_members} = {};
283    
284        $self->{row_active_subset} = "All";
285        $self->{col_active_subset} = "All";
286    
287        $self->{version} = 0;
288        $self->{exchangable} = 0;
289    
290        $self->write_subsystem();
291  }  }
292    
293  #  #
# Line 262  Line 349 
349    
350      if (!$skip_delete)      if (!$skip_delete)
351      {      {
352          $rdbH->SQL("DELETE FROM subsystem_index where subsystem = '$self->{name}'")          $self->delete_indices();
353      }      }
354    
355      #      #
# Line 414  Line 501 
501      $self->{roles} = [];      $self->{roles} = [];
502      $self->{role_abbrs} = [];      $self->{role_abbrs} = [];
503    
504      my $i = 1;      my $i = 0;
505      for my $role (@roles)      for my $role (@roles)
506      {      {
507          my($abbr, $name) = split(/\t/, $role);          my($abbr, $name) = split(/\t/, $role);
# Line 437  Line 524 
524      #      #
525      my($subsetsC, $subsetsR) = split(/\n\n/, $subsets);      my($subsetsC, $subsetsR) = split(/\n\n/, $subsets);
526    
   
527      #      #
528      # Handle column subsets.      # Handle column subsets.
529      #      #
# Line 467  Line 553 
553      {      {
554          my($name, @members) = split(/\s+/, $subset);          my($name, @members) = split(/\s+/, $subset);
555    
556            #
557            # File format has members 1-based.
558            #
559    
560            @members = map { $_ - 1 } @members;
561    
562          push(@{$self->{col_subsets}}, $name);          push(@{$self->{col_subsets}}, $name);
563    
564          #          #
# Line 496  Line 588 
588    
589      if ($subsetsR =~ /(\S+.*\S+)/)      if ($subsetsR =~ /(\S+.*\S+)/)
590      {      {
591          $self->{row_subset_active} = $1;          $self->{row_active_subset} = $1;
592      }      }
593      else      else
594      {      {
595          $self->{row_subset_active} = 'All';          $self->{row_active_subset} = 'All';
596      }      }
597  }  }
598    
# Line 515  Line 607 
607      $self->{genome_index} = {};      $self->{genome_index} = {};
608      $self->{variant_code} = [];      $self->{variant_code} = [];
609    
610      my $i = 1;      my $nr = @{$self->{roles}};
611    
612        my $i = 0;
613      while (<$fh>)      while (<$fh>)
614      {      {
615          chomp;          chomp;
616    
617          my($genome, $variant_code, @row) = split(/\t/);          my($genome, $variant_code, @row) = split(/\t/, $_, $nr + 2);
618    
619          next if $seen{$genome};          next if $seen{$genome};
620          $seen{$genome}++;          $seen{$genome}++;
621    
622          my $j = 1;          my $j = 0;
623    
624          $self->{genome}->[$i] = $genome;          $self->{genome}->[$i] = $genome;
625          $self->{genome_index}->{$genome} = $i;          $self->{genome_index}->{$genome} = $i;
626          $self->{variant_code}->[$i] = $variant_code;          $self->{variant_code}->[$i] = $variant_code;
627    
628          for my $entry (@row)          my $thislen = @row;
629    
630    #       if ($thislen != $nr)
631    #       {
632    #           warn "Genome $genome has wrong column count ($thislen != $nr)\n";
633    #           warn "<$_> $genome $variant_code '", join(":", @row), "'\n";
634    #       }
635    
636            for my $j (0..$nr - 1)
637          {          {
638                my $entry = $row[$j];
639              my $e2 = [map("fig|$genome.peg.$_", split(/,/, $entry))];              my $e2 = [map("fig|$genome.peg.$_", split(/,/, $entry))];
640              $self->{spreadsheet}->[$i]->[$j] = $e2;              $self->{spreadsheet}->[$i]->[$j] = $e2;
641              $self->{spreadsheet_inv}->[$j]->[$i] = $e2;              $self->{spreadsheet_inv}->[$j]->[$i] = $e2;
# Line 545  Line 648 
648    
649  =pod  =pod
650    
651    =head2 write_subsystem()
652    
653    Write the subsystem to the disk.  Updates on-disk data with notes,
654    etc. Perform backups when necessary.
655    
656    =cut
657    
658    sub write_subsystem
659    {
660        my($self) = @_;
661    
662        my $dir = $self->{dir};
663        my $fig = $self->{fig};
664    
665        #
666        # We first move the existing spreadsheet and notes files (if present)
667        # to spreadsheet~ and notes~, and current state.
668        #
669    
670        my $ss_file = "$dir/spreadsheet";
671        my $ss_bak = "$dir/spreadsheet~";
672        my $notes_file = "$dir/notes";
673        my $notes_bak = "$dir/notes~";
674    
675        if (-f $ss_file)
676        {
677            rename($ss_file, $ss_bak);
678        }
679    
680        if (-f $notes_file)
681        {
682            rename($notes_file, $notes_bak);
683        }
684    
685        #
686        # Eval this whole chunk, so that if we get any fatal errors, we can
687        # roll back to the old saved data.
688        #
689    
690        eval {
691            my $fh;
692            open($fh, ">$ss_file") or die "Cannot open $ss_file for writing: $!\n";
693            $self->write_spreadsheet($fh);
694            close($fh);
695    
696            open($fh, ">$notes_file") or die "Cannot open $notes_file for writing: $!\n";
697            print $fh "$self->{notes}\n";
698            close($fh);
699    
700            $self->update_curation_log();
701    
702            #
703            # Write out the piddly stuff.
704            #
705    
706            open($fh, ">$dir/EXCHANGABLE") or die "Cannot write $dir/EXCHANGABLE: $!\n";
707            print $fh "$self->{exchangable}\n";
708            close($fh);
709    
710            #
711            # Process backup files. This is the smae process that determines when the
712            # version number should be bumped, so write the version file afterward.
713            #
714    
715            $self->update_backups();
716    
717            open($fh, ">$dir/VERSION") or die "Cannot write $dir/EXCHANGABLE: $!\n";
718            print $fh "$self->{exchangable}\n";
719            close($fh);
720    
721        };
722    
723        if ($@ ne "")
724        {
725            warn "Spreadsheet write failed, reverting to backup. Error was\n$@\n";
726        }
727    
728    }
729    
730    sub update_curation_log
731    {
732        my($self) = @_;
733    
734        my $fh;
735        my $file = "$self->{dir}/curation.log";
736    
737        my $now = time;
738        my $user = $self->{fig}->get_user();
739    
740        if (-f $file)
741        {
742            open($fh, ">>$file") or die "Cannot open $file for writing: $!\n";
743        }
744        else
745        {
746            open($fh, ">$file") or die "Cannot open $file for writing: $!\n";
747            print $fh "$now\t$user\tstarted\n";
748        }
749        print $fh "$now\t$user\tupdated\n";
750        close($fh);
751    }
752    
753    sub update_backups
754    {
755        my($self) = @_;
756    
757        my $dir = $self->{dir};
758        my $fig = $self->{fig};
759    
760        my $ss_file = "$dir/spreadsheet";
761        my $ss_bak = "$dir/spreadsheet~";
762        my $notes_file = "$dir/notes";
763        my $notes_bak = "$dir/notes~";
764    
765        my $ss_diff = abs((-s $ss_file) - (-s $ss_bak));
766        my $notes_diff = abs((-s $notes_file) - (-s $notes_bak));
767    
768        if ($ss_diff > 10 or $notes_diff > 10)
769        {
770            $self->make_backup();
771        }
772    }
773    
774    sub make_backup
775    {
776        my($self) = @_;
777    
778        my $dir = $self->{dir};
779        my $bak = "$dir/Backup";
780    
781        $self->{fig}->verify_dir($bak);
782    
783        my $ts = time;
784    
785        rename("$dir/spreadsheet~", "$bak/spreadsheet.$ts");
786        rename("$dir/notes~", "$bak/notes.$ts");
787        $self->{version}++;
788    }
789    
790    
791    
792    =pod
793    
794    =head1 write_spreadsheet($fh)
795    
796    Write the spreadsheet for this subsystem to filehandle $fh.
797    
798    =cut
799    
800    sub write_spreadsheet
801    {
802        my($self, $fh) = @_;
803    
804        $self->_write_roles($fh);
805        print $fh "//\n";
806    
807        $self->_write_subsets($fh);
808        print $fh "//\n";
809    
810        $self->_write_spreadsheet($fh);
811    }
812    
813    sub _write_roles
814    {
815        my($self, $fh) = @_;
816    
817        my(@roles, @abbrs);
818    
819        @roles = $self->get_roles();
820        @abbrs = $self->get_abbrs();
821    
822        while (@roles)
823        {
824            my $role = shift(@roles);
825            my $abbr = shift(@abbrs);
826    
827            print $fh "$abbr\t$role\n";
828        }
829    }
830    
831    sub _write_subsets
832    {
833        my($self, $fh) = @_;
834    
835        for my $sub ($self->get_subset_names())
836        {
837            my @members= $self->get_subset($sub);
838    
839            #
840            # member list on disk is 1-based
841            #
842    
843            @members = map { $_ + 1 } @members;
844            print $fh join("\t", $sub, @members), "\n";
845        }
846        print $fh "All\n";
847    
848        #
849        # separator
850        #
851    
852        print $fh "\n";
853    
854        #
855        # genome subsets.
856        #
857    
858        print $fh "All\n";
859    }
860    
861    sub _write_spreadsheet
862    {
863        my($self, $fh) = @_;
864    
865        my(@genomes);
866    
867        @genomes= $self->get_genomes();
868    
869        for (my $i = 0; $i < @genomes; $i++)
870        {
871            my $genome = $genomes[$i];
872            my $vc = $self->get_variant_code($i);
873    
874            my $row = $self->get_row($i);
875    
876            if ($vc eq "")
877            {
878                $vc = "0";
879            }
880            print $fh "$genome\t$vc";
881    
882            for my $entry (@$row)
883            {
884                my(@p);
885    
886                for my $peg (@$entry)
887                {
888                    if ($peg =~ /fig\|$genome\.peg\.(\d+)$/)
889                    {
890                        push(@p, $1);
891                    }
892                    else
893                    {
894                        warn "Bad peg $peg in cell for $genome";
895                    }
896                }
897                print $fh "\t", join(",", @p);
898            }
899            print $fh "\n";
900        }
901    }
902    
903    
904    =pod
905    
906  =head1 get_genomes  =head1 get_genomes
907    
908  =cut  =cut
# Line 555  Line 913 
913    
914      my $glist = $self->{genome};      my $glist = $self->{genome};
915    
916      return @$glist[1..$#$glist];      return @$glist;
917  }  }
918    
919  =pod  =pod
# Line 570  Line 928 
928    
929      my $glist = $self->{variant_code};      my $glist = $self->{variant_code};
930    
931      return @$glist[1..$#$glist];      return @$glist;
932    }
933    
934    sub get_variant_code
935    {
936        my($self, $gidx) = @_;
937        return $self->{variant_code}->[$gidx];
938  }  }
939    
940    
941  sub get_variant_code_for_genome  sub get_variant_code_for_genome
942  {  {
943      my($self, $genome) = @_;      my($self, $genome) = @_;
# Line 587  Line 952 
952    
953      my $rlist = $self->{roles};      my $rlist = $self->{roles};
954    
955      return @$rlist[1..$#$rlist];      return @$rlist;
956    }
957    
958    sub get_abbrs
959    {
960        my($self) = @_;
961    
962        my $rlist = $self->{role_abbrs};
963    
964        return @$rlist;
965  }  }
966    
967  sub get_row :scalar  sub get_row :scalar
# Line 715  Line 1089 
1089      }      }
1090  }  }
1091    
1092  sub get_name :scalar  #
1093    # Subset support
1094    #
1095    
1096    sub get_subset_names
1097  {  {
1098      my($self) = @_;      my($self) = @_;
     return $self->{name};  
 }  
1099    
1100        return @{$self->{col_subsets}};
1101    }
1102    
1103  sub get_version :scalar  sub get_subset
1104  {  {
1105      my($self) = @_;      my($self, $subname) = @_;
1106      return $self->{version};      return @{$self->{col_subset_members}->{$subname}};
1107    }
1108    
1109    =pod
1110    
1111    =head2 set_subset($name, $members)
1112    
1113    Create a subset with the given name and members.
1114    
1115    $members is a list of role names.
1116    
1117    =cut
1118    
1119    sub set_subset
1120    {
1121        my($self, $subname, $list) = @_;
1122    
1123        my $nl = [map { $self->get_role_index($_) } @$list];
1124    
1125        $self->_set_subset($subname, $nl);
1126    }
1127    
1128    =pod
1129    
1130    =head2 _set_subset($name, $members)
1131    
1132    Create a subset with the given name and members.
1133    
1134    Internal version  - here, members is a list of role indices.
1135    
1136    =cut
1137    
1138    sub _set_subset
1139    {
1140        my($self, $subname, $list) = @_;
1141        $self->{col_subset_members}->{$subname} = $list;
1142    }
1143    
1144    #
1145    # Role manipulation.
1146    #
1147    
1148    
1149    =pod
1150    
1151    =head1 set_roles($role_list)
1152    
1153    Set the list of roles. C<$role_list> is a list of tuples C<[$role_name, $abbreviation]>.
1154    
1155    If a role already exists, it is used. If it does not exist, it is created empty.
1156    
1157    =cut
1158    
1159    sub set_roles
1160    {
1161        my($self, $roles) = @_;
1162    
1163        #
1164        # We do this by first creating a new spreadsheet.
1165        #
1166        # It is easiest to do this by manipulating the inverted spreadsheet
1167        # (role-major), and then creating the non-inverted spreadsheet from it.
1168        #
1169    
1170        my $oldss = $self->{spreadsheet};
1171        my $oldssinv = $self->{spreadsheet_inv};
1172    
1173        my $ss = [];
1174        my $ssinv = [];
1175    
1176        my $g = $self->{genome};
1177        my $ng = @$g;
1178    
1179        my $old_roles = $self->{role_index};
1180    
1181        my @role_index_conversion;
1182    
1183    
1184        $self->{abbr} = {};
1185        $self->{role_index} = {};
1186        $self->{roles} = [];
1187        $self->{role_abbrs} = [];
1188    
1189    
1190        for (my $idx = 0; $idx < @$roles; $idx++)
1191        {
1192            my $role = $roles->[$idx]->[0];
1193            my $abbr = $roles->[$idx]->[1];
1194    
1195            my $old_idx = $old_roles->{$role};
1196    
1197            if (defined($old_idx))
1198            {
1199                print "Found old idx $old_idx for $role $idx\n";
1200                print $oldssinv->[$old_idx];
1201                $ssinv->[$idx] = $oldssinv->[$old_idx];
1202    
1203                $role_index_conversion[$old_idx] = $idx;
1204            }
1205            else
1206            {
1207                print "Did not find old role for $role $idx\n";
1208                print Dumper($old_roles);
1209                my $l = [];
1210                for (my $j = 0; $j < $ng; $j++)
1211                {
1212                    $l->[$j] = [];
1213                }
1214    
1215                $ssinv->[$idx] = $l;
1216            }
1217    
1218            #
1219            # While we're here, update the new role and abbrev indexes
1220            #
1221            $self->{role_index}->{$role} = $idx;
1222            $self->{abbr}->{$abbr} = $role;
1223            $self->{roles}->[$idx] = $role;
1224            $self->{role_abbrs}->[$idx] = $abbr;
1225        }
1226    
1227        #
1228        # Now create the uninverted spreadsheet.
1229        #
1230    
1231        for (my $gidx = 0; $gidx < $ng; $gidx++)
1232        {
1233            my $row = [];
1234            $ss->[$gidx] = $row;
1235            for (my $ridx = 0; $ridx < @$roles; $ridx++)
1236            {
1237                $row->[$ridx] = $ssinv->[$ridx]->[$gidx];
1238            }
1239        }
1240    
1241        $self->{spreadsheet} = $ss;
1242        $self->{spreadsheet_inv} = $ssinv;
1243    
1244        #
1245        # Fix up the subsets.
1246        #
1247    
1248    
1249        for my $subset ($self->get_subset_names())
1250        {
1251            my $n = [];
1252            for my $idx ($self->get_subset($subset))
1253            {
1254                my $new = $role_index_conversion[$idx];
1255                if (defined($new))
1256                {
1257                    push(@$n, $new);
1258                }
1259            }
1260            $self->_set_subset($subset, $n);
1261        }
1262    
1263    }
1264    
1265    =pod
1266    
1267    =head1 C<add_role($role, $abbr)>
1268    
1269    Add the given role to the spreadsheet.
1270    
1271    This causes a new column to be added, with empty values in each cell.
1272    
1273    We do nothing if the role is already present.
1274    
1275    Return the index of the new role.
1276    
1277    =cut
1278    
1279    sub add_role
1280    {
1281        my($self, $role, $abbr) = @_;
1282    
1283        if (defined($self->get_role_index($role)))
1284        {
1285            warn "Role $role already present\n";
1286            return undef;
1287        }
1288    
1289        #
1290        # Add to the roles list. It goes at the end.
1291        #
1292    
1293        my $idx = @{$self->{roles}};
1294        $self->{roles}->[$idx] = $role;
1295        $self->{role_abbrs}->[$idx] = $abbr;
1296        $self->{role_index}->{$role} = $idx;
1297        $self->{abbr}->{$abbr} = $role;
1298    
1299        #
1300        # Update the spreadsheet.
1301        # On the standard one, we have to go through all the rows adding
1302        # a columnt to each.
1303        #
1304        # On the inverted one, we add a column with [] in each entry.
1305        #
1306    
1307        my $ng = @{$self->{genome}};
1308        my $newcol = [];
1309    
1310        for (my $i = 0; $i < $ng; $i++)
1311        {
1312            my $cell = [];
1313            # print "nr: Adding cell $cell for gidx=$i ridx=$idx\n";
1314            $self->{spreadsheet}->[$i]->[$idx] = $cell;
1315            $newcol->[$i] = $cell;
1316        }
1317    
1318        $self->{spreadsheet_inv}->[$idx] = $newcol;
1319    
1320        return $idx;
1321    }
1322    
1323    =pod
1324    
1325    =head1 remove_role($role)
1326    
1327    Remove the role from the spreadsheet.
1328    
1329    We do nothing if the role is not present.
1330    
1331    =cut
1332    
1333    sub remove_role
1334    {
1335        my($self, $role) = @_;
1336    
1337        my $idx = $self->get_role_index($role);
1338        if (!defined($idx))
1339        {
1340            warn "Role $role not present\n";
1341            return undef;
1342        }
1343    
1344        #
1345        # Remove from the roles list.
1346        #
1347    
1348        my $abbr = $self->{role_abbrs}->[$idx];
1349    
1350        splice(@{$self->{roles}}, $idx, 1);
1351        splice(@{$self->{role_abbrs}}, $idx, 1);
1352        delete $self->{role_index}->{$role};
1353        delete $self->{abbr}->{$abbr};
1354    
1355        #
1356        # Update the spreadsheet.
1357        # On the standard one, we have to go through all the rows removing
1358        # the column from each.
1359        #
1360        # On the inverted one, we just remove the column.
1361        #
1362    
1363        my $ng = @{$self->{genome}};
1364        my $newcol = [];
1365    
1366        for (my $i = 0; $i < $ng; $i++)
1367        {
1368            splice(@{$self->{spreadsheet}->[$i]}, $idx, 1);
1369        }
1370    
1371        splice(@{$self->{spreadsheet_inv}}, $idx, 1);
1372    
1373        #
1374        # We need to rewrite the subsets. if $idx was present in one, it is
1375        # removed. Any index >$idx is decremented.
1376        #
1377    
1378        for my $subset ($self->get_subset_names())
1379        {
1380            my @n;
1381    
1382            for my $sidx ($self->get_subset($subset))
1383            {
1384                if ($sidx < $idx)
1385                {
1386                    push(@n, $sidx);
1387                }
1388                elsif ($sidx > $idx)
1389                {
1390                    push(@n, $sidx - 1);
1391                }
1392            }
1393    
1394            $self->_set_subset($subset, [@n]);
1395        }
1396    }
1397    
1398    =pod
1399    
1400    =head1 C<add_genome($genome, $abbr)>
1401    
1402    Add the given genome to the spreadsheet.
1403    
1404    This causes a new row to be added, with empty values in each cell.
1405    
1406    We do nothing if the genome is already present.
1407    
1408    Return the index of the new genome.
1409    
1410    =cut
1411    
1412    sub add_genome
1413    {
1414        my($self, $genome) = @_;
1415    
1416        my $idx = $self->get_genome_index($genome);
1417        if (defined($idx))
1418        {
1419            warn "Genome $genome already present\n";
1420            return $idx;
1421        }
1422    
1423        #
1424        # Add to the genomes list. It goes at the end.
1425        #
1426    
1427        my $idx = @{$self->{genome}};
1428        $self->{genome}->[$idx] = $genome;
1429        $self->{genome_index}->{$genome} = $idx;
1430    
1431        #
1432        # Update the spreadsheet.
1433        # On the inverted one, we have to go through all the columns adding
1434        # a row to each.
1435        #
1436        # On the regular one, we add a row with [] in each entry.
1437        #
1438    
1439        my $nr = @{$self->{roles}};
1440        my $newrow = [];
1441    
1442        for my $i (0.. $nr - 1)
1443        {
1444            my $cell = [];
1445            # print "ng: Adding cell $cell for gidx=$idx ridx=$i\n";
1446            $self->{spreadsheet_inv}->[$i]->[$idx] = $cell;
1447            $newrow->[$i] = $cell;
1448        }
1449    
1450        $self->{spreadsheet}->[$idx] = $newrow;
1451    
1452        return $idx;
1453    }
1454    
1455    =pod
1456    
1457    =head1 remove_genome($genome)
1458    
1459    Remove the genome from the spreadsheet.
1460    
1461    We do nothing if the genome is not present.
1462    
1463    =cut
1464    
1465    sub remove_genome
1466    {
1467        my($self, $genome) = @_;
1468    
1469        my $idx = $self->get_genome_index($genome);
1470        if (!defined($idx))
1471        {
1472            warn "Genome $genome not present\n";
1473            return undef;
1474        }
1475    
1476        #
1477        # Remove from the genomes list.
1478        #
1479    
1480        splice(@{$self->{genome}}, $idx, 1);
1481        splice(@{$self->{variant_code}}, $idx, 1);
1482    
1483        delete $self->{genome_index}->{$genome};
1484    
1485        #
1486        # Update the spreadsheet.
1487        # On the inverted one, we have to go through all the columns removing
1488        # the row from each.
1489        #
1490        # On the standard one, we just remove the row.
1491        #
1492    
1493        my $nr = @{$self->{roles}};
1494    
1495        for my $i (0 .. $nr - 1)
1496        {
1497            splice(@{$self->{spreadsheet_inv}->[$i]}, $idx, 1);
1498        }
1499    
1500        splice(@{$self->{spreadsheet}}, $idx, 1);
1501    
1502    }
1503    
1504    sub get_name :scalar
1505    {
1506        my($self) = @_;
1507        return $self->{name};
1508    }
1509    
1510    
1511    sub get_version :scalar
1512    {
1513        my($self) = @_;
1514        return $self->{version};
1515  }  }
1516    
1517  sub get_curator :scalar  sub get_curator :scalar
# Line 734  Line 1520 
1520      return $self->{curator};      return $self->{curator};
1521  }  }
1522    
1523    #
1524    # Subsystem copying logic
1525    #
1526    
1527    =pod
1528    
1529    =head2 add_to_subsystem($subsystem_name, $columns, $notes_flag)
1530    
1531    Merge the given columns from $subsystem_name into this subsystem. Append the
1532    notes from the subsystem if $notes_flag is true.
1533    
1534    =cut
1535    
1536    sub add_to_subsystem
1537    {
1538        my($self, $subsystem_name, $cols, $add_notes) = @_;
1539    
1540        my $ss = $self->{fig}->get_subsystem($subsystem_name);
1541    
1542        if (!$ss)
1543        {
1544            warn "Cannot open subsystem '$subsystem_name' to copy from";
1545            return;
1546        }
1547    
1548        #
1549        # Merge the data from the other subsystem.
1550        #
1551        # First we assure ourselves that we have the appropriate roles. While
1552        # we do this, build the list of row indices (in this subsystem) that
1553        # map to the roles we are adding.
1554        #
1555    
1556        #
1557        # local_roles[$his_role] = $my_role (map from other role idx to local role idx)
1558        #
1559    
1560        my @local_roles;
1561    
1562        #
1563        # his_roles = list of role indices corresponding to the remote roles.
1564        #
1565        my @his_roles;
1566    
1567        for my $his_role (@$cols)
1568        {
1569            my $idx = $self->get_role_index($his_role);
1570            my $his_idx = $ss->get_role_index($his_role);
1571    
1572            if (!defined($his_idx))
1573            {
1574                confess "Cannot map his role $his_role\n";
1575            }
1576            push(@his_roles, $his_idx);
1577    
1578            if (!defined($idx))
1579            {
1580                my $his_abbr = $ss->get_role_abbr($his_idx);
1581    
1582                $idx = $self->add_role($his_role, $his_abbr);
1583                print "Adding missing role $his_role idx=$idx\n";
1584            }
1585            else
1586            {
1587                print "Found existing role $his_role idx=$idx\n";
1588            }
1589    
1590    
1591            $local_roles[$his_idx] = $idx;
1592        }
1593    
1594        #
1595        # Similar scan to ensure that we have rows for the genomes
1596        # that are in the other subsystem.
1597        #
1598    
1599        my @local_genomes;
1600    
1601        my @his_genomes = $ss->get_genomes();
1602    
1603        for my $his_idx (0..@his_genomes - 1)
1604        {
1605            my $genome = $his_genomes[$his_idx];
1606    
1607            my $my_idx = $self->get_genome_index($genome);
1608    
1609            if (!defined($my_idx))
1610            {
1611                #
1612                # Not there, need to add.
1613                #
1614    
1615                $my_idx = $self->add_genome($genome);
1616                print "Adding missing genome $genome idx=$my_idx\n";
1617            }
1618            else
1619            {
1620                print "Found existing genome $genome idx=$my_idx\n";
1621            }
1622    
1623            $local_genomes[$his_idx] = $my_idx;
1624        }
1625    
1626    
1627        #
1628        # Now that we have our local roles set up to receive the data,
1629        # process the incoming roles one at a time.
1630        #
1631    
1632    
1633        for my $his_role (@his_roles)
1634        {
1635            my $my_col = $self->get_col($local_roles[$his_role]);
1636            my $his_col = $ss->get_col($his_role);
1637    
1638            #
1639            # $his_col is the information for $his_role, indexed by
1640            # genome in @his_genomes.
1641            #
1642            # $my_col is hte information for my copy of $his_role,
1643            # indexed by genome in MY genome list.
1644            #
1645    
1646            my $my_role = $local_roles[$his_role];
1647    
1648            print "merging: $self->{roles}->[$my_role] $ss->{roles}->[$his_role] his_role=$his_role my_role=$my_role\n";
1649    
1650            for my $his_gidx (0 .. @his_genomes - 1)
1651            {
1652                my $hisent = $his_col->[$his_gidx];
1653    
1654                my $my_gidx = $local_genomes[$his_gidx];
1655    
1656                my $myent = $my_col->[$my_gidx];
1657    
1658                print "  his_gidx=$his_gidx my_gidx=$my_gidx hisent=@$hisent myent=@$myent\n";
1659    
1660                my %new;
1661                map { $new{$_}++ } @$hisent;
1662                map { $new{$_}++ } @$myent;
1663    
1664                @$myent = keys(%new);
1665    
1666                print "  new entry: @$myent\n";
1667            }
1668        }
1669    }
1670    
1671  sub dump  sub dump
1672  {  {

Legend:
Removed from v.1.24  
changed lines
  Added in v.1.25

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3