[Bio] / SubsystemEditor / WebPage / ShowVariants.pm Repository:
ViewVC logotype

View of /SubsystemEditor/WebPage/ShowVariants.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (download) (as text) (annotate)
Mon Mar 24 20:17:14 2008 UTC (11 years, 10 months ago) by bartels
Branch: MAIN
Changes since 1.5: +57 -27 lines
fixed a bug - quotemeta rules.

package SubsystemEditor::WebPage::ShowVariants;

use strict;
use warnings;
use URI::Escape;
use HTML;
use Data::Dumper;

use FIG;

use base qw( WebPage );

1;

##################################################
# Method for registering components etc. for the #
# application                                    #
##################################################
sub init {
  my ( $self ) = @_;

  $self->application->register_component(  'Table', 'ShowVariantsTable'  );
  $self->application->register_component(  'Table', 'FRTable'  );
  $self->application->register_component(  'Table', 'VarDescTable'  );
}

sub require_javascript {

  return [ './Html/showfunctionalroles.js' ];

}

##############################################
# Website content is returned by this method #
##############################################
sub output {
  my ( $self ) = @_;

  my $can_alter = 0;
  my $user = $self->application->session->user;
  
  my $fig = new FIG;
  my $cgi = $self->application->cgi;
  
  my $name = $cgi->param( 'subsystem' );
  my $ssname = $name;
  $ssname =~ s/\_/ /g;

  my $dbmaster = DBMaster->new( -database => 'WebAppBackend' );
  my $ppoapplication = $dbmaster->Backend->init( { name => 'SubsystemEditor' } );

  # get a seeduser #
  my $seeduser = '';
  if ( defined( $user ) && ref( $user ) ) {
    my $preferences = $dbmaster->Preferences->get_objects( { user => $user,
							     name => 'SeedUser',
							     application => $ppoapplication } );
    if ( defined( $preferences->[0] ) ) {
      $seeduser = $preferences->[0]->value();
    }
  }

  if ( $user && $user->has_right( $self->application, 'edit', 'subsystem', $name ) ) {
    $can_alter = 1;
    $fig->set_user( $seeduser );
  }

  ######################
  # Construct the menu #
  ######################

  my $menu = $self->application->menu();

  # Build nice tab menu here
  $menu->add_category( 'Subsystem Info', "SubsysEditor.cgi?page=ShowSubsystem&subsystem=$name" );
  $menu->add_category( 'Functional Roles', "SubsysEditor.cgi?page=ShowFunctionalRoles&subsystem=$name" );
  $menu->add_category( 'Diagram', "SubsysEditor.cgi?page=ShowDiagram&subsystem=$name" );
  $menu->add_category( 'Illustrations', "SubsysEditor.cgi?page=ShowIllustrations&subsystem=$name" );
  $menu->add_category( 'Spreadsheet', "SubsysEditor.cgi?page=ShowSpreadsheet&subsystem=$name" );
  $menu->add_category( 'Show Check', "SubsysEditor.cgi?page=ShowCheck&subsystem=$name" );
  $menu->add_category( 'Show Tree', "SubsysEditor.cgi?page=ShowTree&subsystem=$name" );
 
  
  ##############################
  # Construct the page content #
  ##############################
  my $comment;
  my $error;

  my $content = "<H1>Variants for Subsystem:  $ssname</H1>";

  if ( !defined( $name ) ) {
    $content .= "<B>No subsystem given</B>";
    return $content;
  }

  my $subsystem = $fig->get_subsystem( $name );

  my $datahash = get_data( $fig, $subsystem );

  my $application = $self->application;

  if ( $cgi->param( 'set_variants' ) ) {
    $comment .= '<BR>';
    $comment .= set_variants( $cgi, $fig, $name, $subsystem, $application, $datahash );
    $datahash = get_data( $fig, $subsystem );
  }
  elsif ( $cgi->param( 'addsave_variants' ) ) {
    my @varcodes = $cgi->param( 'VARIANT' );
    my @vardescs = $cgi->param( 'VARIANTDESC' );
    my %varhash;

    for ( my $i = 0; $i < scalar( @varcodes ); $i++ ) {

      if ( $varcodes[$i] eq '' ) {
	if ( $vardescs[$i] ne '' ) {
	  $comment .= "No Variant Code given for description ".$vardescs[$i].", so this variant could not be saved.<BR>\n";
	}
	next;
      }
      if ( defined( $varhash{ $varcodes[$i] } ) ) {
	$comment .= "Variant ".$varcodes[$i]." already has the description ".$varhash{ $varcodes[$i] }.", so description ".$vardescs[$i]." was ignored.<BR>\n";
	next;
      }

      $varhash{ $varcodes[$i] } = $vardescs[$i];
    }
    my $newvarcode = $cgi->param( 'NEWVARIANT' );
    my $newvardesc = $cgi->param( 'NEWVARIANTDESC' );
    if ( defined( $newvarcode ) && $newvarcode ne '' && defined( $newvardesc ) && $newvardesc ne '' ) {
      if ( $newvarcode eq '' ) {
	if ( $newvarcode ne '' ) {
	  $comment .= "No Variant Code given for description $newvardesc, so this variant could not be saved.<BR>\n";
	}
      }
      elsif ( defined( $varhash{ $newvarcode } ) ) {
	$comment .= "Variant $newvarcode already has the description $newvardesc, so description $newvardesc was ignored.<BR>\n";
      }
      else {
	$varhash{ $newvarcode } = $newvardesc;
      }
    }

    $subsystem->set_variants( \%varhash );
    $subsystem->incr_version();
    $subsystem->db_sync();
    $subsystem->write_subsystem();
  }

  $content .= show_variants( $self, $cgi, $fig, $name, $subsystem, $can_alter, $datahash );

  ###############################
  # Display errors and comments #
  ###############################
 
  if ( defined( $error ) && $error ne '' ) {
    $self->application->add_message( 'warning', $error );
  }
  if ( defined( $comment ) && $comment ne '' ) {
    $self->application->add_message( 'info', $comment );
  }
  return $content;
}

###############
# data method #
###############
sub get_data {
  my ( $fig, $subsystem ) = @_;

  my $datahash = {};

  my @genomes        = $subsystem->get_genomes;
  my %variant_codes = map { $_ => $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) ) } @genomes;
  my @roles          = $subsystem->get_roles;

  $datahash->{ 'genomes' } = \@genomes;
  $datahash->{ 'varcodes' } = \%variant_codes;
  $datahash->{ 'roles' } = \@roles;  
  
  return $datahash;
}

#########################################################
# show table with variants and button for changing them #
#########################################################
sub show_variants {
  my ( $self, $cgi, $fig, $name, $sub, $can_alter, $datahash ) = @_;

  my $application = $self->application();

  my $cont = '';

  # get some datapoints #
  my @genomes        = @{ $datahash->{ 'genomes' } };
  my %variant_codes = %{ $datahash->{ 'varcodes' } };
  my @roles          = @{ $datahash->{ 'roles' } };
  
  my ( $abbrev, $frtable ) = format_roles( $application, $fig, $cgi, $sub );
  
  my( @has, $role, %has_filled );
  foreach my $genome ( @genomes ) {
    @has = ();
    foreach $role (@roles)
      {
	push(@has,($sub->get_pegs_from_cell($genome,$role) > 0) ? $abbrev->{$role} : ());
      }
    $has_filled{join(",",@has)}->{$variant_codes{$genome}}++;
  }
  
  my ( $col_hdrs, $pattern_uq );
  if ( $can_alter ) {
    $col_hdrs = [ { name => "Pattern" }, { name => "# Genomes with Pattern" },
		  { name => "Existing Variant Code" }, { name => "Set To" } ];
  }
  else {
    $col_hdrs = [ { name => "Pattern" }, { name => "# Genomes with Pattern" },
		  { name => "Existing Variant Code" } ];
  }

  my $tab = [];
  foreach $pattern_uq ( sort keys( %has_filled ) ) {

    my $pattern = quotemeta( $pattern_uq );

    my @codes = keys( %{ $has_filled{ $pattern_uq } } );
    my $code;
    my $nrow = @codes;
    if ( @codes > 0 ) {
      $code = shift @codes;
      if ( $can_alter ) {
	push( @$tab, [ $pattern_uq,
		       $has_filled{ $pattern_uq }->{ $code },
		       $code,		     
		       $cgi->textfield(-name => "p##:##$pattern##:##$code", -size => 5, -value => $code, -override => 1)
		     ]);
      }
      else {
	push( @$tab, [ $pattern_uq,
		       $has_filled{ $pattern_uq }->{ $code },
		       $code
		     ]);
      }
    }
    
    foreach $code ( @codes ) {
      if ( $can_alter ) {
	push( @$tab, [ $pattern_uq, 
		       $has_filled{ $pattern_uq }->{ $code },
		       $code,
		       $cgi->textfield(-name => "p##:##$pattern##:##$code", -size => 5, -value => $code, -override => 1)
		     ]);
      }
      else {
	push( @$tab, [ $pattern_uq, 
		       $has_filled{ $pattern_uq }->{ $code },
		       $code
		     ]);
      }
    }
  }

  $cont .= $frtable;
  $cont .= $self->start_form();
  
  # create table from parsed data
  my $table = $application->component( 'ShowVariantsTable' );
  $table->columns( $col_hdrs );
  $table->data( $tab );

  ############################################
  # Variant Descriptions from the Notes file #
  ############################################
  $cont .= "<H2>Variant descriptions</H2>\n";
  my $variants = $sub->get_variants();

  my $infotable = '';
  if ( $can_alter ) {
    $infotable .= "<TABLE><TR><TH>Variant</TH><TH>Description</TH></TR>";
    foreach my $kv ( sort keys %$variants ) {
      $infotable .= "<TR><TD><INPUT TYPE=TEXT NAME='VARIANT' ID='VARIANT".$kv."' VALUE='$kv'></TD><TD><INPUT TYPE=TEXT NAME='VARIANTDESC' ID='VARIANTDESC".$kv."' VALUE='".$variants->{ $kv }."' STYLE='width: 500px;'></TD></TR>";
    }
    $infotable .= "<TR><TD><INPUT TYPE=TEXT NAME='NEWVARIANT' ID='NEWVARIANT'></TD><TD><INPUT TYPE=TEXT NAME='NEWVARIANTDESC' ID='NEWVARIANTDESC' STYLE='width: 500px;'></TD></TR>";
    $infotable .= "<TR><TD>";
    $infotable .= $cgi->submit( -name => "addsave_variants", -value => "Add/Save Variants" );
    $infotable .= "</TD></TR></TABLE>";

    $cont .= $infotable;
  }
  else {
    my $infotable = $application->component( 'VarDescTable' );
    $infotable->columns( [ { name => "Variant" }, { name => "Description" } ] );

    my $vardata;
    foreach my $kv ( sort keys %$variants ) {
      push @$vardata, [ $kv, $variants->{ $kv } ];
    }
    $infotable->data( $vardata );
    $cont .= $infotable->output();
  } 


  $cont .= "<H2>Variant groups</H2>\n";
  $cont .= $application->component( 'ShowVariantsTable' )->output();
   
  $cont .= $cgi->hidden(-name => 'request', -value => 'set_variants', -override => 1);
  $cont .= $cgi->hidden(-name => 'subsystem', -value => $name, -override => 1);
  if ( $can_alter ) {
    $cont .= $cgi->br;
  }
  $cont .= $cgi->submit( -name => "set_variants", -value => "Set Variants" );
  $cont .= $self->end_form();
  
  return $cont;
}
	    

###############################
# get a functional role table #
###############################
sub format_roles {
    my( $application, $fig, $cgi, $subsystem ) = @_;
    my( $i );

    my $col_hdrs = [ "Column", "Abbrev", "Functional Role" ];

    my $n = 1;
    my ( $tab, $abbrevP ) = format_existing_roles( $fig, $subsystem, \$n );

    # create table from parsed data
    my $table = $application->component( 'FRTable' );
    $table->columns( $col_hdrs );
    $table->data( $tab );

    my $formatted = '<H2>Functional Roles</H2>';
    $formatted .= $application->component( 'FRTable' )->output();

    $formatted .= "<BR><BR>";
    return ( $abbrevP, $formatted );
}

#########################################
# get rows of the functional role table #
#########################################
sub format_existing_roles {
    my ( $fig, $subsystem, $nP ) = @_;
    my $tab = [];
    my $abbrevP = {};

    foreach my $role ( $subsystem->get_roles ) {
      my $i = $subsystem->get_role_index( $role );
      my $abbrev = $role ? $subsystem->get_role_abbr( $i ) : "";
      $abbrevP->{ $role } = $abbrev;
      push( @$tab, [ $$nP, $abbrev, $role ] );
    }

    return ( $tab, $abbrevP );
}


##############################################
# change the variants in the subsystems file #
##############################################
sub set_variants {
    my ( $cgi, $fig, $subsys, $sub, $application, $datahash ) = @_;

    my @genomes        = @{ $datahash->{ 'genomes' } };
    my %variant_codes = %{ $datahash->{ 'varcodes' } };
    my @roles          = @{ $datahash->{ 'roles' } };

    my ( $abbrev, $frtable ) = format_roles( $application, $fig, $cgi, $sub );

    my ( %genomes_with );
    foreach my $genome ( @genomes ) {
      my $vc = $variant_codes{ $genome };
      
      my @has = ();
      foreach my $role ( @roles ) {
	push( @has, ( $sub->get_pegs_from_cell( $genome, $role ) > 0 ) ? $abbrev->{ $role } : () );
      }
      my $pattern = quotemeta( join( ",", @has ) );
      push( @{ $genomes_with{ "$pattern, $vc" } }, $genome );
    }

    my $comment = '';
    my @params = grep { $_ =~ /^p##:##/ } $cgi->param;

    foreach my $param (@params) {

      if ( $param =~ /^p##:##(.*)##:##(.*)$/ ) {
	my ( $pattern, $vc ) = ( $1, $2 );

	$pattern =~ s/ //g;
	$vc      =~ s/ //g;
	my $to = $cgi->param( $param );

	if ( my $x = $genomes_with{ "$pattern, $vc" } ) {
	  foreach my $genome ( @$x ) {

	    if ( $to ne $variant_codes{ $genome } ) {

	      my $old = $variant_codes{$genome};
	      my $gs = $fig->genus_species($genome);
	      $comment .= "resetting $genome $gs from $old to $to<BR>\n";
	      $sub->set_variant_code( $sub->get_genome_index( $genome ), $to );
	    }
	  }

	}
      }
    }

    $sub->incr_version();
    $sub->db_sync();
    $sub->write_subsystem();

    return $comment;
}


MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3