Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'develop' of /software/vertres/git/origin/vr-codebase in…

…to develop
  • Loading branch information...
commit 12af9572cbb2108dcfa6b431874b9fd00b073c32 2 parents 7c2b937 + 33ec091
@cj5-sanger cj5-sanger authored
Showing with 1,488 additions and 1,840 deletions.
  1. +1 −0  Build.PL
  2. +45 −7 modules/VRTrack/VRTrack.pm
  3. +51 −1 modules/Vcf.pm
  4. +316 −0 modules/VertRes/QCGrind/ViewUtil.pm
  5. BIN  scripts/bamcheck
  6. +6 −1 scripts/bamcheck-mousewrapper
  7. +55 −13 scripts/bamcheck.c
  8. +9 −1 scripts/run-beagle
  9. +4 −4 scripts/run-mpileup
  10. +13 −6 scripts/update_db_vrpipe.sh
  11. +1 −1  scripts/vcf-annotate
  12. +198 −0 scripts/vcf-contrast
  13. +8 −2 scripts/vcf-fix-ploidy
  14. +25 −3 scripts/vr-wrapper
  15. +16 −22 scripts/vrtracking_tool
  16. +23 −3 scripts/weekly_new_lane_report
  17. +30 −1 t/VRTrack/hierarchy_noreq.t
  18. 0  web_code/lookseq/lookseq.html
  19. +1 −0  web_code/lookseq/lookseq.js
  20. +149 −0 web_code/map-view/map_lanes_view.pl
  21. +51 −0 web_code/map-view/map_projects_view.pl
  22. +21 −394 web_code/map-view/map_view.pl
  23. +191 −0 web_code/pending-view/pending_requests_view.pl
  24. +21 −409 web_code/pending-view/pending_view.pl
  25. +0 −420 web_code/pending-view/pending_view2.pl
  26. +17 −10 web_code/qc_grind/study_lanes.pl
  27. +20 −542 web_code/sample-mapping/sample_mapping.pl
  28. +165 −0 web_code/sample-mapping/sample_mapping_lanes_view.pl
  29. +51 −0 web_code/sample-mapping/sample_mapping_projects_view.pl
  30. 0  web_code/snps/snps.css
  31. 0  web_code/snps/snps.js
View
1  Build.PL
@@ -44,6 +44,7 @@ my $build = MyBuild->new(
'Net::FTP::Robust' => 0,
'Time::Format' => 0,
'IO::Capture::Stderr' => 0,
+ 'Math::Random' => 0,
},
pm_files => get_pm_files(),
script_files => 'scripts'
View
52 modules/VRTrack/VRTrack.pm
@@ -346,6 +346,39 @@ sub hierarchy_path_of_lane {
my ($self, $lane, $template) = @_;
($lane && ref($lane) && $lane->isa('VRTrack::Lane')) || confess "A VRTrack::Lane must be supplied\n";
+ return $self->hierarchy_path_of_object($lane,$template);
+}
+
+=head2 hierarchy_path_of_object
+
+ Arg [1] : VRTrack::Project, VRTrack::Sample, VRTrack::Library or VRTrack::Lane object
+ Arg [2] : hierarchy template (Optional)
+ Example : my $lane_hier = $track->hierarchy_path_of_object($vrlane);
+ Description: Retrieve the hierarchy path for a project, sample, library or lane according
+ to the template defined by environment variable 'DATA_HIERARCHY', to the
+ root of the hierarchy. Template defaults to:
+ 'project:sample:technology:library:lane'
+ Possible terms are 'genus', 'species-subspecies', 'strain',
+ 'individual', 'project', 'projectid', 'sample', 'technology',
+ 'library', 'lane'. ('strain' and 'individual' are synonymous)
+ Does not check the filesystem.
+ Returns undef if hierarchy cannot be built.
+ Returntype : string
+
+=cut
+
+sub hierarchy_path_of_object {
+ my ($self, $object, $template) = @_;
+
+ # Object types
+ my %object_type = ('VRTrack::Project' => 'project',
+ 'VRTrack::Sample' => 'sample',
+ 'VRTrack::Library' => 'library',
+ 'VRTrack::Lane' => 'lane');
+
+ (defined($object) && exists($object_type{ref($object)})) || confess "A recognised object type must be supplied\n";
+
+
# For all acceptable terms, we generate the corresponding word, but for
# others we just append the term itself to the hierarchy. This allows for
# words like DATA or TRACKING to be injected into the hierarchy without much
@@ -354,12 +387,15 @@ sub hierarchy_path_of_lane {
# Since not all possible terms might be used in the template, we will only
# create objects if necessary (accessing db is expensive).
my %objs;
- my $get_lane = sub { return $lane; };
- my $get_lib = sub { $objs{library} ||= VRTrack::Library->new($self, $lane->library_id); return $objs{library}; };
- my $get_sample = sub { $objs{sample} ||= VRTrack::Sample->new($self, &{$get_lib}->sample_id); return $objs{sample}; };
- my $get_project = sub { $objs{project} ||= VRTrack::Project->new($self, &{$get_sample}->project_id); return $objs{project}; };
- my $get_individual = sub { $objs{individual} ||= VRTrack::Individual->new($self, &{$get_sample}->individual_id); return $objs{individual}; };
- my $get_species = sub { $objs{species} ||= VRTrack::Species->new($self, &{$get_individual}->species_id); return $objs{species}; };
+
+ $objs{$object_type{ref($object)}} = $object; # set input object
+
+ my $get_lane = sub { return $objs{lane}; };
+ my $get_lib = sub { $objs{library} ||= eval { VRTrack::Library->new($self, &{$get_lane}->library_id) }; return $objs{library}; };
+ my $get_sample = sub { $objs{sample} ||= eval { VRTrack::Sample->new($self, &{$get_lib}->sample_id) }; return $objs{sample}; };
+ my $get_project = sub { $objs{project} ||= eval { VRTrack::Project->new($self, &{$get_sample}->project_id) }; return $objs{project}; };
+ my $get_individual = sub { $objs{individual} ||= eval { VRTrack::Individual->new($self, &{$get_sample}->individual_id) }; return $objs{individual}; };
+ my $get_species = sub { $objs{species} ||= eval { VRTrack::Species->new($self, &{$get_individual}->species_id) }; return $objs{species}; };
my %terms = (genus => $get_species,
'species-subspecies' => $get_species,
strain => $get_individual,
@@ -376,7 +412,7 @@ sub hierarchy_path_of_lane {
$template = $ENV{DATA_HIERARCHY} || 'project:sample:technology:library:lane';
}
my @path = split(/:/, $template);
-
+
my @hier_path_bits;
foreach my $term (@path) {
my $get_method = $terms{$term};
@@ -414,6 +450,8 @@ sub hierarchy_path_of_lane {
else {
push(@hier_path_bits, $term);
}
+
+ last if $term eq $object_type{ref($object)}; # Finish at object directory
}
return File::Spec->catdir(@hier_path_bits);
View
52 modules/Vcf.pm
@@ -1188,7 +1188,7 @@ sub get_field
{
$isep = index($col,$delim,$prev_isep);
if ( $itag==$idx ) { last; }
- if ( $isep==-1 ) { $self->throw("The index out of range: $col:$isep .. $idx"); }
+ if ( $isep==-1 ) { return '.'; } # This is valid, missing fields can be ommited from genotype columns
$prev_isep = $isep+1;
$itag++;
}
@@ -2647,6 +2647,54 @@ sub get_samples
}
+=head2 get_column
+
+ About : Convenient way to get data for a sample
+ Usage : my $rec = $vcf->next_data_array(); my $sample_col = $vcf->get_column($rec, 'NA0001');
+ Args 1 : Array pointer returned by next_data_array
+ 2 : Column/Sample name
+
+=cut
+
+sub get_column
+{
+ my ($self,$line,$column) = @_;
+ if ( !exists($$self{has_column}{$column}) ) { $self->throw("No such column: [$column]\n"); }
+ my $idx = $$self{has_column}{$column};
+ return $$line[$idx-1];
+}
+
+=head2 get_column_name
+
+ About : Mapping between zero-based VCF column and its name
+ Usage : my $vcf = Vcf->new(); $vcf->parse_header(); my $name = $vcf->get_column_name(1); # returns POS
+ Args : Index of the column (0-based)
+
+=cut
+
+sub get_column_name
+{
+ my ($self,$idx) = @_;
+ if ( $idx >= @{$$self{columns}} ) { $self->throw("The index out of bounds\n"); }
+ return $$self{columns}[$idx];
+}
+
+=head2 get_column_index
+
+ About : Mapping between VCF column name and its zero-based index
+ Usage : my $vcf = Vcf->new(); $vcf->parse_header(); my $name = $vcf->get_column_index('POS'); # returns 1
+ Args : Name of the column
+
+=cut
+
+sub get_column_index
+{
+ my ($self,$column) = @_;
+ if ( !exists($$self{has_column}{$column}) ) { $self->throw("No such column: [$column]\n"); }
+ return $$self{has_column}{$column}-1;
+}
+
+
#------------------------------------------------
# Version 3.2 specific functions
@@ -3208,6 +3256,8 @@ sub Vcf4_1::validate_line
$$self{_contig_validated}{$$line{CHROM}} = 1;
}
+ if ( index($$line{CHROM},':')!=-1 ) { $self->warn("Colons not allowed in chromosome names: $$line{CHROM}\n"); }
+
# Is the ID composed of alphanumeric chars
if ( !($$line{ID}=~/^\S+$/) ) { $self->warn("Expected non-whitespace ID at $$line{CHROM}:$$line{POS}, but got [$$line{ID}]\n"); }
}
View
316 modules/VertRes/QCGrind/ViewUtil.pm
@@ -0,0 +1,316 @@
+package VertRes::QCGrind::ViewUtil;
+use base qw(VertRes::QCGrind::Util);
+# QC Grind common variables and modules
+use strict;
+
+sub new {
+ my $self={};
+
+ $self->{SCRIPTS} = {
+ MAP_VIEW => 'map_view.pl',
+ MAP_PROJECTS_VIEW => 'map_projects_view.pl',
+ MAP_LANES_VIEW => 'map_lanes_view.pl',
+ PENDING_VIEW => 'pending_view.pl',
+ PENDING_REQ_VIEW => 'pending_requests_view.pl',
+ SAMPLE_MAPPING => 'sample_mapping.pl',
+ SAMPMAP_PROJECTS_VIEW => 'sample_mapping_projects_view.pl',
+ SAMPMAP_LANES_VIEW => 'sample_mapping_lanes_view.pl',
+ QCGRIND_LANE => '../qc_grind/lane_view.pl',
+ QCGRIND_SAMPLES => '../qc_grind/samples_view.pl',
+ };
+
+
+ $self->{CSS} = <<CSS ;
+
+.centerFieldset {
+text-align:center;
+}
+
+.centerFieldset fieldset {
+margin-left:auto;
+margin-right:auto;
+/* INHERITED ALIGNMENT IS CENTER. ONLY INCLUDE THIS IF YOU WANT */
+/* TO CHANGE THE ALIGNMENT OF THE CONTENTS OF THE FIELDSET */
+text-align:left;
+}
+
+.centerFieldset table {
+ margin-left:auto;
+ margin-right:auto;
+}
+
+.coolfieldset, .coolfieldset.expanded{
+ border:1px solid #aaa;
+}
+
+.coolfieldset.collapsed{
+ border:0;
+ border-top:1px solid #aaa;
+}
+
+.coolfieldset legend{
+ padding-left:13px;
+ font-weight:bold;
+ cursor:pointer;
+}
+
+.coolfieldset legend, .coolfieldset.expanded legend{
+ background: transparent url(http://www.sanger.ac.uk/modelorgs/mousegenomes/images/expanded.gif) no-repeat center left;
+}
+
+.coolfieldset.collapsed legend{
+ background: transparent url(http://www.sanger.ac.uk/modelorgs/mousegenomes/images/collapsed.gif) no-repeat center left;
+}
+
+table.summary {
+ border-collapse: collapse;
+ font: 0.9em Verdana, Arial, Helvetica, sans-serif;
+}
+
+table.summary td {
+ white-space: nowrap;
+ text-align: right;
+ padding-right: 1em;
+ padding-left: 1em;
+ padding-top: 2px;
+ padding-bottom: 2px;
+ border-bottom: #83a4c3 dotted 1px;
+}
+
+table.summary tr.header th, table.summary tr.header td {
+ font-weight:bold;
+ border-bottom: #83a4c3 solid 1px;
+ text-align: left;
+ vertical-align:middle;
+}
+
+table.summary tr.level th, table.summary tr.level td {
+ font-weight:bold;
+ border-bottom: #83a4c3 dotted 1px;
+ text-align: left;
+ vertical-align:middle;
+}
+
+table.summary tr.total th, table.summary tr.total td {
+ font-weight:bold;
+ background-color: #CBDCED;
+ border-bottom: #83a4c3 dotted 1px;
+ text-align: right;
+ vertical-align:middle;
+}
+
+input.btn {
+ font: bold 150% 'trebuchet ms',helvetica,sans-serif;
+ border:1px solid;
+ border-color: #707070 #000 #000 #707070;
+}
+
+tr:nth-child(2n+1) {
+ background-color: #ecf1ef;
+}
+
+input.btnhov {
+ cursor:pointer;
+ border-color: #c63 #930 #930 #c63;
+}
+
+.clear
+{
+ clear: both;
+ display: block;
+ overflow: hidden;
+ visibility: hidden;
+ width: 0;
+ height: 0;
+}
+
+img.preview:hover {
+ width: 480px;
+ height: 480px;
+}
+
+.thumbnail{
+position: relative;
+z-index: 0;
+}
+
+.thumbnail:hover{
+background-color: transparent;
+z-index: 50;
+}
+
+.thumbnail span{ /*CSS for enlarged image*/
+position: absolute;
+padding: 5px;
+left: -1000px;
+visibility: hidden;
+text-decoration: none;
+}
+
+.thumbnail span img{ /*CSS for enlarged image*/
+border-width: 0;
+padding: 2px;
+}
+
+.thumbnail:hover span{ /*CSS for enlarged image on hover*/
+visibility: visible;
+top: 0;
+left: -480px; /*position where enlarged image should offset horizontally */
+
+}
+CSS
+
+ bless $self;
+ return $self;
+}
+
+
+sub displayDatabasesPage {
+ my ($self,$title,$cgi,$script,$alldb) = @_;
+
+ print qq[ <h2 align="center" style="font: normal 900 1.5em arial">$title</h2> ];
+
+ my @main_dbs = qw (vrtrack_human_wgs vrtrack_human_wes vrtrack_mouse_wgs vrtrack_mouse_wes);
+ print qq[
+ <div class="centerFieldset">
+ <fieldset style="width: 500px">
+ <legend>Main Databases</legend>
+ ];
+ foreach( @main_dbs ) {
+ print $cgi->p("<a href='$script?db=$_'> $_ </a>");
+ }
+ print qq[ </fieldset> </div> ];
+
+ my @uk10k_dbs = qw (vrtrack_uk10k_cohort vrtrack_uk10k_neuro vrtrack_uk10k_obesity vrtrack_uk10k_rare);
+ print qq[
+ <div class="centerFieldset">
+ <fieldset style="width: 500px">
+ <legend>UK10K Databases</legend>
+ ];
+ foreach( @uk10k_dbs ) {
+ print $cgi->p("<a href='$script?db=$_'> $_ </a>");
+ }
+ print qq[ </fieldset> </div> ];
+ if ($alldb) {
+ my %done;
+ push (@main_dbs, @uk10k_dbs);
+ foreach (@main_dbs) {
+ $done{$_}++;
+ }
+ my @dbs = $self->fetchTrackingDatabases();
+ print qq[
+ <div class="centerFieldset">
+ <fieldset id="fieldset1" class="coolfieldset" style="width: 500px">
+ <legend>Other Databases (click to show/hide)</legend> <div>
+ ];
+ foreach( @dbs ) {
+ next if $done{$_};
+ print $cgi->p("<a href='$script?db=$_'> $_ </a>");
+ }
+ print qq[ </div> </fieldset> </div>
+ <script>
+ \$('#fieldset1').coolfieldset({collapsed:true});
+ </script>];
+ }
+}
+
+sub displayDatabasePage
+{
+ my ($self,$title,$cgi,$vrtrack,$db,$init_script,$lanes_script) = @_;
+
+ print qq[
+ <h2 align="center" style="font: normal 900 1.5em arial"><a href="$init_script">$title</a></h2>
+ <h3 align="center" style="font: normal 700 1.5em arial">Database : $db</h3>
+ <div class="centerFieldset">
+ <fieldset style="width: 500px">
+ <legend>Select study to View</legend>
+ ];
+ my @projects = sort {$a->name cmp $b->name} @{$vrtrack->projects()};
+ foreach my $project (@projects)
+ {
+ my $id = $project->id();
+ print qq[<p><a href="$lanes_script?db=$db&amp;proj_id=$id">].$project->name().qq[</a></p>];
+ }
+ print qq[
+ </fieldset>
+ </div>
+ ];
+}
+
+sub fetchTrackingDatabases
+{
+ my ($self) = @_;
+ my @dbs;
+ my $web_db = 'vrtrack_web_index';
+ my $vrtrack = $self->connectToDatabase($web_db);
+ $self->displayError( "Failed to connect to web database: $web_db" ) unless defined( $vrtrack );
+ my $sql = qq[SELECT db_name FROM tracking_database];
+ my $sth = $vrtrack->{_dbh}->prepare($sql);
+ if ($sth->execute()) {
+ my ($col1);
+ $sth->bind_col(1, \$col1);
+ while ($sth->fetch) {
+ push @dbs, $col1;
+ }
+ }
+ return @dbs;
+}
+
+sub getDatabaseID
+{
+ my ($self, $db) = @_;
+ my $db_id;
+ my $web_db = 'vrtrack_web_index';
+ my $vrtrack = $self->connectToDatabase($web_db);
+ $self->displayError( "Failed to connect to web database: $web_db" ) unless defined( $vrtrack );
+ my $sql = qq[SELECT db_id FROM tracking_database where db_name = ?];
+ my $sth = $vrtrack->{_dbh}->prepare($sql);
+ if ($sth->execute($db)) {
+ my ($id);
+ $sth->bind_col(1, \$id);
+ while ($sth->fetch) {
+ $db_id = $id;
+ }
+ }
+ return $db_id;
+}
+
+sub getSampleMappings
+{
+ my ($self, $db_id, $pid) = @_;
+ my %mappings;
+ my $web_db = 'vrtrack_web_index';
+ my $vrtrack = $self->connectToDatabase($web_db);
+ $self->displayError( "Failed to connect to web database: $web_db" ) unless defined( $vrtrack );
+ my $sql = qq[SELECT supplier_name, accession_number, sanger_sample_name FROM sample_id_mapping where db_id = ? and project_id = ?];
+ my $sth = $vrtrack->{_dbh}->prepare($sql);
+ if ($sth->execute($db_id, $pid)) {
+ my ($supp, $acc, $sang);
+ $sth->bind_columns(\($supp, $acc, $sang));
+ while ($sth->fetch) {
+ push @{ $mappings{$sang} }, ($supp, $acc);
+ }
+ }
+ return %mappings;
+}
+
+sub fetchProjectName
+{
+ my ($self, $db_id, $pid) = @_;
+ my $pname;
+ my $web_db = 'vrtrack_web_index';
+ my $vrtrack = $self->connectToDatabase($web_db);
+ $self->displayError( "Failed to connect to web database: $web_db" ) unless defined( $vrtrack );
+ my $sql = qq[SELECT project_name FROM db_projects where project_id = ? and db_id =?];
+ my $sth = $vrtrack->{_dbh}->prepare($sql);
+ if ($sth->execute($pid, $db_id)) {
+ my ($name);
+ $sth->bind_col(1, \$name);
+ while ($sth->fetch) {
+ $pname = $name;
+ }
+ }
+ return $pname;
+}
+
+1;
View
BIN  scripts/bamcheck
Binary file not shown
View
7 scripts/bamcheck-mousewrapper
@@ -36,7 +36,7 @@ TMPFILE=`mktemp /tmp/bamcheck-mousewrapper.XXXXXXXXXX` || exit 1
die()
{
- echo "killed, removing $TMPFILE"
+ if [ -e $TMPFILE ]; then cat $TMPFILE; fi
rm -f $TMPFILE
exit 1
}
@@ -44,6 +44,11 @@ die()
trap 'die' TERM
trap 'die' INT
+read -t 1 -n 1 A && if [ $? -eq 0 ]; then
+ echo "The mousewrapper does not accept streamed BAMs."
+ exit 1
+fi
+
bamcheck $@ -t /lustre/scratch102/projects/mouse/ref/bamcheck-mousewrapper.regions > $TMPFILE || die
DUPL=`cat $TMPFILE | grep ^SN | grep 'reads duplicated:'` || die
rm -f $TMPFILE
View
68 scripts/bamcheck.c
@@ -29,6 +29,7 @@
#include "faidx.h"
#include "khash.h"
#include "sam.h"
+#include "sam_header.h"
#include "razf.h"
#define BWA_MIN_RDLEN 35
@@ -47,13 +48,14 @@ typedef struct
uint64_t offset;
}
faidx1_t;
-KHASH_MAP_INIT_STR(s, faidx1_t)
-KHASH_MAP_INIT_STR(str, int)
+KHASH_MAP_INIT_STR(kh_faidx, faidx1_t)
+KHASH_MAP_INIT_STR(kh_bam_tid, int)
+KHASH_MAP_INIT_STR(kh_rg, const char *)
struct __faidx_t {
RAZF *rz;
int n, m;
char **name;
- khash_t(s) *hash;
+ khash_t(kh_faidx) *hash;
};
typedef struct
@@ -152,10 +154,11 @@ typedef struct
// Auxiliary data
int flag_require, flag_filter;
- double sum_qual; // For calculating average quality value
- samfile_t *sam; // Unused
- faidx_t *fai; // Reference sequence for GC-depth graph
- int argc; // Command line arguments to be printed on the output
+ double sum_qual; // For calculating average quality value
+ samfile_t *sam;
+ khash_t(kh_rg) *rg_hash; // Read groups to include, the array is null-terminated
+ faidx_t *fai; // Reference sequence for GC-depth graph
+ int argc; // Command line arguments to be printed on the output
char **argv;
}
stats_t;
@@ -406,7 +409,7 @@ void count_mismatches_per_cycle(stats_t *stats,bam1_t *bam_line)
void read_ref_seq(stats_t *stats,int32_t tid,int32_t pos)
{
- khash_t(s) *h;
+ khash_t(kh_faidx) *h;
khiter_t iter;
faidx1_t val;
char *chr, c;
@@ -416,7 +419,7 @@ void read_ref_seq(stats_t *stats,int32_t tid,int32_t pos)
chr = stats->sam->header->target_name[tid];
// ID of the sequence name
- iter = kh_get(s, h, chr);
+ iter = kh_get(kh_faidx, h, chr);
if (iter == kh_end(h))
error("No such reference sequence [%s]?\n", chr);
val = kh_value(h, iter);
@@ -565,6 +568,13 @@ void realloc_buffers(stats_t *stats, int seq_len)
void collect_stats(bam1_t *bam_line, stats_t *stats)
{
+ if ( stats->rg_hash )
+ {
+ const uint8_t *rg = bam_aux_get(bam_line, "RG");
+ if ( !rg ) return;
+ khiter_t k = kh_get(kh_rg, stats->rg_hash, (const char*)(rg + 1));
+ if ( k == kh_end(stats->rg_hash) ) return;
+ }
if ( stats->flag_require && (bam_line->core.flag & stats->flag_require)!=stats->flag_require )
return;
if ( stats->flag_filter && (bam_line->core.flag & stats->flag_filter) )
@@ -1074,10 +1084,10 @@ size_t mygetline(char **line, size_t *n, FILE *fp)
void init_regions(stats_t *stats, char *file)
{
khiter_t iter;
- khash_t(str) *header_hash;
+ khash_t(kh_bam_tid) *header_hash;
bam_init_header_hash(stats->sam->header);
- header_hash = (khash_t(str)*)stats->sam->header->hash;
+ header_hash = (khash_t(kh_bam_tid)*)stats->sam->header->hash;
FILE *fp = fopen(file,"r");
if ( !fp ) error("%s: %s\n",file,strerror(errno));
@@ -1096,7 +1106,7 @@ void init_regions(stats_t *stats, char *file)
if ( i>=nread ) error("Could not parse the file: %s [%s]\n", file,line);
line[i] = 0;
- iter = kh_get(str, header_hash, line);
+ iter = kh_get(kh_bam_tid, header_hash, line);
int tid = kh_val(header_hash, iter);
if ( iter == kh_end(header_hash) )
{
@@ -1186,6 +1196,32 @@ int is_in_regions(bam1_t *bam_line, stats_t *stats)
return 1;
}
+void init_group_id(stats_t *stats, char *id)
+{
+ if ( !stats->sam->header->dict )
+ stats->sam->header->dict = sam_header_parse2(stats->sam->header->text);
+ void *iter = stats->sam->header->dict;
+ const char *key, *val;
+ int n = 0;
+ stats->rg_hash = kh_init(kh_rg);
+ while ( (iter = sam_header2key_val(iter, "RG","ID","SM", &key, &val)) )
+ {
+ if ( !strcmp(id,key) || (val && !strcmp(id,val)) )
+ {
+ khiter_t k = kh_get(kh_rg, stats->rg_hash, key);
+ if ( k != kh_end(stats->rg_hash) )
+ fprintf(stderr, "[init_group_id] The group ID not unique: \"%s\"\n", key);
+ int ret;
+ k = kh_put(kh_rg, stats->rg_hash, key, &ret);
+ kh_value(stats->rg_hash, k) = val;
+ n++;
+ }
+ }
+ if ( !n )
+ error("The sample or read group \"%s\" not present.\n", id);
+}
+
+
void error(const char *format, ...)
{
if ( !format )
@@ -1201,6 +1237,7 @@ void error(const char *format, ...)
printf(" -F, --filtering-flag <int> Filtering flag, 0 for unset [0]\n");
printf(" -h, --help This help message\n");
printf(" -i, --insert-size <int> Maximum insert size [8000]\n");
+ printf(" -I, --id <string> Include only listed read group or sample name\n");
printf(" -l, --read-length <int> Include in the statistics only reads with the given read length []\n");
printf(" -m, --most-inserts <float> Report only the main part of inserts [0.99]\n");
printf(" -q, --trim-quality <int> The BWA trimming parameter [0]\n");
@@ -1223,6 +1260,7 @@ int main(int argc, char *argv[])
{
char *targets = NULL;
char *bam_fname = NULL;
+ char *group_id = NULL;
samfile_t *sam = NULL;
char in_mode[5];
@@ -1264,10 +1302,11 @@ int main(int argc, char *argv[])
{"target-regions",0,0,'t'},
{"required-flag",0,0,'f'},
{"filtering-flag",0,0,'F'},
+ {"id",0,0,'I'},
{0,0,0,0}
};
int opt;
- while ( (opt=getopt_long(argc,argv,"?hdsr:c:l:i:t:m:q:f:F:",loptions,NULL))>0 )
+ while ( (opt=getopt_long(argc,argv,"?hdsr:c:l:i:t:m:q:f:F:I:",loptions,NULL))>0 )
{
switch (opt)
{
@@ -1287,6 +1326,7 @@ int main(int argc, char *argv[])
case 'm': stats->isize_main_bulk = atof(optarg); break;
case 'q': stats->trim_qual = atoi(optarg); break;
case 't': targets = optarg; break;
+ case 'I': group_id = optarg; break;
case '?':
case 'h': error(NULL);
default: error("Unknown argument: %s\n", optarg);
@@ -1319,6 +1359,7 @@ int main(int argc, char *argv[])
if ((sam = samopen(bam_fname, in_mode, NULL)) == 0)
error("Failed to open: %s\n", bam_fname);
stats->sam = sam;
+ if ( group_id ) init_group_id(stats, group_id);
bam1_t *bam_line = bam_init1();
// .. arrays
stats->quals_1st = calloc(stats->nquals*stats->nbases,sizeof(uint64_t));
@@ -1391,6 +1432,7 @@ int main(int argc, char *argv[])
free(stats->del_cycles_2nd);
destroy_regions(stats);
free(stats);
+ if ( stats->rg_hash ) kh_destroy(kh_rg, stats->rg_hash);
return 0;
}
View
10 scripts/run-beagle
@@ -237,8 +237,16 @@ sub beagle
$self->cmd("touch $outfile");
return;
}
- if ( -s "$outfile.e" ) { `cat $outfile.e >> $outfile.e.saved`; }
my $mem = int($self->get_limits('memory') * 0.8);
+ if ( -s "$outfile.e" )
+ {
+ # At this stage the LSF memory cannot be increased, but we can tell java that more memory is available.
+ # This way it should fail with the proper 'memory limit exceeded' status and the pipeline will assign
+ # memory in the next retry.
+ my @err = `head -1 $outfile.e`;
+ if ( $err[0] =~ /java.lang.OutOfMemoryError/ ) { $mem = int($self->get_limits('memory') * 1.5); }
+ `cat $outfile.e >> $outfile.e.saved`;
+ }
my $known = $$self{known_vcf} eq '--' ? '' : "markers=$outdir/$region.01.markers unphased=$outdir/$region.01.known_haps.gz missing=?";
$self->cmd(qq[java -Xmx${mem}m $$self{java_args} -jar $$self{beagle_jar} $$self{beagle_args} like=$outdir/$region.01.impute_haps.gz $known out=$outdir/$region.02 >>$outfile.o 2>$outfile.e]);
if ( -s "$outfile.e" ) { $self->throw("Expected empty error file: $outfile.e"); }
View
8 scripts/run-mpileup
@@ -129,8 +129,8 @@ sub new
$$self{usage} .=
"Usage: run-mpileup\n" .
"Options:\n" .
- " -c, --clean Clean all temporary files\n" .
- " -m, --mrProper Clean all temporary files, including the population directories and BCFs, leaving only toplevel VCFs\n" .
+ " -c, --clean Clean all temporary files (and do nothing else)\n" .
+ " -m, --mrProper Clean all temporary files, including the population directories and BCFs, leaving only toplevel VCFs (and do nothing else)\n" .
" -o, --outdir <dir> Output directory\n" .
"\n";
@@ -371,7 +371,7 @@ sub clean
my $chr = $$chunk{chr};
my $from = $$chunk{from};
my $to = $$chunk{to};
- for my $suffix qw(samples vcf.gz vcf.gz.tbi)
+ for my $suffix (qw(samples vcf.gz vcf.gz.tbi))
{
my $file = "$outdir/$pop/$chr/$chr:$from-$to.$suffix";
unlink($file) unless !-e $file;
@@ -937,7 +937,7 @@ sub concat_chroms
];
close($fh);
- $self->cmd("vcf-concat -f $chunks_list | vcf-annotate -f $tmp.annot | bgzip -c > $concat.part");
+ $self->cmd("vcf-concat -p -f $chunks_list | vcf-annotate -f $tmp.annot | bgzip -c > $concat.part");
$self->tabix_part($concat);
}
my $conf = $$self{vqsr_filtering};
View
19 scripts/update_db_vrpipe.sh
@@ -9,17 +9,24 @@ then
fi
DB="$1"
-TAX=""
+DBEXISTS=$(mysql -u vreseq_ro -hmcs4a --batch --skip-column-names -e "SHOW DATABASES LIKE '$DB'" | grep $DB > /dev/null; echo "$?")
+if [ $DBEXISTS -eq 1 ];then
+ echo "A database with the name $DB does not exist."
+ exit
+fi
+TAX=""
if [ $# -eq 2 ]
then
TAX="-tax $2"
fi
-DBEXISTS=$(mysql -u vreseq_ro -hmcs4a --batch --skip-column-names -e "SHOW DATABASES LIKE '$DB'" | grep $DB > /dev/null; echo "$?")
-if [ $DBEXISTS -eq 1 ];then
- echo "A database with the name $DB does not exist."
- exit
+ARG_UP=""
+if [[ $DB =~ "uk10k" ]]
+then
+ ARG_UP="-u -v"
+else
+ ARG_UP="-u -sup -nop -v"
fi
ROOT="/lustre/scratch105"
@@ -33,4 +40,4 @@ export ORACLE_HOME=/software/oracle_client-10.2.0
mysqldump -u $VRTRACK_RW_USER -p$VRTRACK_PASSWORD -P$VRTRACK_PORT -h$VRTRACK_HOST $DB > $DUMPS
-$BIN_EXT/update_pipeline.pl -s $CONF/$DB"_studies" -d $DB $TAX -sup -nop -v
+$BIN_EXT/update_pipeline.pl -s $CONF/$DB"_studies" -d $DB $TAX $ARG_UP
View
2  scripts/vcf-annotate
@@ -906,7 +906,7 @@ sub apply_user_defined_filters
elsif ( exists($$filter{format_tag}) )
{
my $idx = $$opts{vcf}->get_tag_index($$line[8],$$filter{format_tag},':');
- if ( $idx<1 ) { next; }
+ if ( $idx<0 ) { next; }
$MATCH = $$opts{vcf}->get_sample_field($line,$idx);
}
$apply{ $$filter{name} } = &{$$filter{test}} == $PASS ? 0 : 1;
View
198 scripts/vcf-contrast
@@ -0,0 +1,198 @@
+#!/usr/bin/env perl
+#
+# Author: petr.danecek@sanger
+#
+
+use strict;
+use warnings;
+use Carp;
+use Vcf;
+
+my $opts = parse_params();
+query_vcf($opts);
+
+exit;
+
+#--------------------------------
+
+sub error
+{
+ my (@msg) = @_;
+ if ( scalar @msg ) { confess @msg; }
+ print
+ "About: Find differences amongst samples\n",
+ "Usage: vcf-contrast +<list> -<list> [OPTIONS] file.vcf.gz\n",
+ "Options:\n",
+ " +<list> List of samples where unique variant is expected\n",
+ " -<list> List of background samples\n",
+ " -d, --min-DP <int> Minimum depth across all -<list> samples\n",
+ " -f, --apply-filters Skip sites with FILTER column different from PASS or \".\"\n",
+ " -h, -?, --help This help message.\n",
+ "Example:\n",
+ " # Test if any of the samples A,B is different from all C,D,E\n",
+ " vcf-contrast +A,B -C,D,E -m file.vcf.gz\n",
+ "\n",
+ " # Similar to above but require minimum mapping quality of 20\n",
+ " vcf-annotate -f MinMQ=20 file.vcf.gz | vcf-contrast +A,B,C -D,E,F -f\n",
+ "\n";
+ exit -1;
+}
+
+
+sub parse_params
+{
+ my $opts = {};
+ while (defined(my $arg=shift(@ARGV)))
+ {
+ if ( -e $arg ) { $$opts{vcf}=$arg; next }
+ if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { error(); }
+ if ( $arg eq '-d' || $arg eq '--min-DP' ) { $$opts{min_dp}=shift(@ARGV); next; }
+ if ( $arg eq '-f' || $arg eq '--apply-filters' ) { $$opts{apply_filters}=1; next; }
+ if ( $arg eq '-m' || $arg eq '--mendelian' ) { $$opts{mendelian}=1; next; }
+ if ( $arg=~/^\+/ && !exists($$opts{var_samples}) ) { @{$$opts{var_samples}}=split(/,/,$'); next }
+ if ( $arg=~/^-/ && !exists($$opts{bg_samples}) ) { @{$$opts{bg_samples}}=split(/,/,$'); next }
+ error("Unknown parameter \"$arg\". Run -h for help.\n");
+ }
+ if ( !exists($$opts{var_samples}) ) { error("Missing the list of variant samples (+<list>).\n") }
+ if ( !exists($$opts{bg_samples}) ) { error("Missing the list of background samples (-<list>).\n") }
+ return $opts;
+}
+
+sub init_columns
+{
+ my ($vcf,@samples) = @_;
+ my @out;
+ for my $sample (@samples)
+ {
+ push @out, $vcf->get_column_index($sample);
+ }
+ return (@out);
+}
+
+sub query_vcf
+{
+ my ($opts) = @_;
+ my $vcf = exists($$opts{vcf}) ? Vcf->new(file=>$$opts{vcf}) : Vcf->new(fh=>\*STDIN);
+ $vcf->parse_header;
+
+ my @cols = qw(CHROM POS NOVEL_ALLELE NOVEL_GT SCORE IS_INDEL);
+ for my $sample (@{$$opts{var_samples}}) { push @cols,"+GT:$sample"; }
+ for my $sample (@{$$opts{var_samples}}) { push @cols,"+PL:$sample"; }
+ for my $sample (@{$$opts{bg_samples}}) { push @cols,"-GT:$sample"; }
+ for my $sample (@{$$opts{bg_samples}}) { push @cols,"-PL:$sample"; }
+ print "#";
+ for (my $i=0; $i<@cols; $i++)
+ {
+ print "[",$i+1,"]$cols[$i]\t";
+ }
+ print "\n";
+
+ my @var_cols = init_columns($vcf,@{$$opts{var_samples}});
+ my @bg_cols = init_columns($vcf,@{$$opts{bg_samples}});
+
+ while (my $rec=$vcf->next_data_array)
+ {
+ if ( $$opts{apply_filters} && $$rec[6] ne '.' && $$rec[6] ne 'PASS' ) { next; }
+
+ my $ipl = $vcf->get_tag_index($$rec[8],'PL',':');
+ if ( $ipl<0 ) { error("todo: currently only PL-based analysis implemented"); }
+ my $idp;
+ if ( exists($$opts{min_dp}) )
+ {
+ $idp = $vcf->get_tag_index($$rec[8],'DP',':');
+ if ( $idp<0 ) { error("todo: DP not available"); }
+ }
+
+ my (@bg_pls, @bg_als, @bg_gts, @var_pls,@var_gts, $min_dp);
+ for my $bg_col (@bg_cols)
+ {
+ if ( defined $idp )
+ {
+ my $dp = $vcf->get_field($$rec[$bg_col],$idp);
+ if ( !defined $min_dp or $min_dp>$dp ) { $min_dp=$dp; }
+ }
+ my $pl = $vcf->get_field($$rec[$bg_col],$ipl);
+ my @gt = likely_gt($pl);
+ push @bg_pls, $pl;
+ push @bg_als, \@gt;
+ push @bg_gts, join('/',sort @gt);
+ }
+ if ( defined $min_dp && $min_dp<$$opts{min_dp} ) { next; }
+
+ my $novel_gt = 1;
+ my $novel_al = 0;
+ my $min_score;
+ for my $var_col (@var_cols)
+ {
+ my $var_pl = $vcf->get_field($$rec[$var_col],$ipl);
+ my @var_als = likely_gt($var_pl);
+ my $var_gt = join('/',sort @var_als);
+ push @var_pls, $var_pl;
+ push @var_gts, $var_gt;
+ my $bg_score;
+ my %als;
+ for (my $i=0; $i<@bg_cols; $i++)
+ {
+ my $score = same_pls($var_pl, $bg_pls[$i]);
+ if ( !defined $bg_score or $score<$bg_score ) { $bg_score = $score; }
+ for my $al (@{$bg_als[$i]}) { $als{$al} = 1; }
+ if ( $var_gt eq $bg_gts[$i] ) { $novel_gt = 0; }
+ }
+ if ( !$bg_score ) { next; }
+ if ( !defined $min_score or $min_score>$bg_score ) { $min_score = $bg_score; }
+
+ for my $al (@var_als)
+ {
+ if ( !exists($als{$al}) ) { $novel_al = 1; }
+ }
+ }
+
+ if ( !$min_score ) { next; }
+ if ( !$novel_gt && !$novel_al ) { next; }
+
+ my $is_indel = 0;
+ for my $al ($$rec[3], $$rec[4])
+ {
+ if ( length($al)>1 ) { $is_indel=1; last; }
+ }
+
+ print "$$rec[0]\t$$rec[1]\t$novel_al\t$novel_gt\t$min_score\t$is_indel\t";
+ print join("\t",@var_gts), "\t", join("\t",@var_pls), "\t";
+ print join("\t",@bg_gts), "\t", join("\t",@bg_pls), "\n";
+ }
+}
+
+sub likely_gt
+{
+ my ($pl) = @_;
+ my @pls = split(/,/,$pl);
+
+ my ($min,$imin,$jmin);
+ my $idx=0;
+ my $i=0;
+ while ($idx<@pls)
+ {
+ for (my $j=0; $j<=$i; $j++)
+ {
+ if ( !defined $min or $min>$pls[$idx] ) { $min=$pls[$idx]; $imin=$i; $jmin=$j; }
+ $idx++;
+ }
+ $i++;
+ }
+ return ($jmin,$imin);
+}
+
+sub same_pls
+{
+ my ($pla,$plb) = @_;
+ my @pla = split(/,/,$pla);
+ my @plb = split(/,/,$plb);
+ my $min;
+ my $imin;
+ for (my $i=0; $i<@pla; $i++)
+ {
+ if ( !defined $min or $pla[$i]+$plb[$i]<$min ) { $min=$pla[$i]+$plb[$i]; $imin=$i; }
+ }
+ return $min;
+}
+
View
10 scripts/vcf-fix-ploidy
@@ -23,9 +23,10 @@ sub error
"Usage: cat broken.vcf | vcf-fix-ploidy [OPTIONS] > fixed.vcf\n",
"Options:\n",
" -a, --assumed-sex <sex> M or F, required if the list is not complete in -s\n",
+ " -l, --fix-likelihoods Add or remove het likeihoods (not the default behaviour)\n",
+ " -m, --missing-for-hets Insert missing GT instead of the first allele for hets.\n",
" -p, --ploidy <file> Ploidy definition. The default is shown below.\n",
" -s, --samples <file> List of sample sexes (sample_name [MF]).\n",
- " -l, --fix-likelihoods Add or remove het likeihoods (not the default behaviour)\n",
" -h, -?, --help This help message.\n",
"Default ploidy definition:\n",
" ploidy =>\n",
@@ -75,6 +76,7 @@ sub parse_params
};
while (defined(my $arg=shift(@ARGV)))
{
+ if ( $arg eq '-m' || $arg eq '--missing-for-hets' ) { $$opts{missing_for_hets}=1; next }
if ( $arg eq '-p' || $arg eq '--ploidy' ) { my $file=shift(@ARGV); my $x=do $file; $$opts{ploidy}=$x; next }
if ( $arg eq '-s' || $arg eq '--samples' ) { $$opts{samples}=shift(@ARGV); next }
if ( $arg eq '-a' || $arg eq '--assumed-sex' ) { $$opts{assumed_sex}=shift(@ARGV); next }
@@ -165,7 +167,11 @@ sub fix_ploidy
my ($a1,$a2) = $vcf->split_gt($gt);
if ( $$samples{$sample}==1 )
{
- if ( defined $a2 ) { $new_gt = $a1; $nchanged{stripped}{$sample}++; }
+ if ( defined $a2 )
+ {
+ $new_gt = ( $a1 ne $a2 && $$opts{missing_for_hets} ) ? '.' : $a1;
+ $nchanged{stripped}{$sample}++;
+ }
if ( $pl )
{
my @pls = split(/,/, $pl);
View
28 scripts/vr-wrapper
@@ -19,12 +19,34 @@ for package in $PACKAGES; do
fi
done
+function usage()
+{
+ echo "Usage: vr-wrapper [OPTIONS] [PROFILE] cmd"
+ echo "Options:"
+ echo " -e No shell expansion, use exec instead of eval"
+ echo " -h This help message"
+ echo "Examples:"
+ echo " vr-wrapper - 'set > variables.txt'"
+ echo " vr-wrapper /path/to/optional/profile 'set > variables.txt'"
+ echo " vr-wrapper -e ~/.vrw/local printf 'hello world!\n'"
+ exit 1
+}
+
+if [ $# -eq 0 -o "$1" == '-h' ]; then
+ usage
+fi
+
+cmd="eval"
+if [ "$1" == '-e' ]; then
+ cmd="exec"
+ shift 1
+fi
+
if [ "$1" != '-' ]; then
. $1
fi
+umask 007
shift 1
-
-umask 007
-eval $@
+$cmd "$@"
View
38 scripts/vrtracking_tool
@@ -371,28 +371,22 @@ sub get_vrtrack_objects
sub get_vrtrack_directory
{
- my ($vrtrack, $vrobject) = @_;
- if ($vrobject->isa('VRTrack::Lane')) {
- return $vrtrack->hierarchy_path_of_lane_name($vrobject->name);
- }
- #project:sample:technology:library
- elsif ($vrobject->isa('VRTrack::Library')) {
- my $sample = VRTrack::Sample->new($vrtrack, $vrobject->sample_id);
- my $project = VRTrack::Project->new($vrtrack, $sample->project_id);
- my $seq_tech_name = $vrobject->seq_tech() ? $vrobject->seq_tech->name : 'SLX';
- return File::Spec->catdir($project->hierarchy_name, $sample->hierarchy_name, $seq_tech_name, $vrobject->hierarchy_name);
- }
- elsif ($vrobject->isa('VRTrack::Sample')) {
- my $project = VRTrack::Project->new($vrtrack, $vrobject->project_id);
- return File::Spec->catdir($project->hierarchy_name, $vrobject->hierarchy_name)
- }
- elsif ($vrobject->isa('VRTrack::Project')) {
- return $vrobject->hierarchy_name;
- }
- else {
- croak "Unable to retrieve the tracking directory as the tracking object type is not recognised.\n";
- }
-}
+ my ($vrtrack, $vrobject) = @_;
+
+ my %recognised_type = ('VRTrack::Project' => 1,
+ 'VRTrack::Sample' => 1,
+ 'VRTrack::Library' => 1,
+ 'VRTrack::Lane' => 1);
+
+ # Check object
+ croak "Unable to retrieve the tracking directory as the tracking object is not defined.\n" unless defined $vrobject;
+ croak "Unable to retrieve the tracking directory as the tracking object type is not recognised.\n" unless $recognised_type{ref($vrobject)};
+
+ my $vrtrack_directory = $vrtrack->hierarchy_path_of_object($vrobject);
+ croak "Unable to retrieve the tracking directory as could not build hierarchy path for tracking object.\n" unless defined $vrtrack_directory;
+
+ return $vrtrack_directory;
+}
sub get_reset_flag_objects
{
View
26 scripts/weekly_new_lane_report
@@ -1,13 +1,33 @@
#!/usr/bin/env perl
+use strict;
+use warnings;
+
use DBI;
use VertRes::Utils::VRTrackFactory;
use Carp;
+use Getopt::Long;
-use strict;
-use warnings;
+my ($dbfile, $help);
+
+GetOptions(
+ 'd|dbs=s' => \$dbfile,
+ 'h|help' => \$help,
+);
-my @dbs = qw(vrtrack_human_wgs vrtrack_human_wes vrtrack_mouse_wgs vrtrack_mouse_wes);
+($dbfile && !$help) or die <<USAGE;
+Usage options:
+ Produce weekly reports for databases listed in a file:
+ $0 -d <file_of_dbs>
+USAGE
+
+my @dbs;
+open DBFILE, '<', $dbfile;
+while ( <DBFILE> ) {
+ chomp;
+ push @dbs, $_;
+}
+close DBFILE;
#SQL for vrtrack databases:
my $sql_select_current_lane_count = qq[SELECT p.name, count(*) from latest_lane l, latest_library b, latest_sample s, latest_project p
View
31 t/VRTrack/hierarchy_noreq.t
@@ -1,6 +1,7 @@
#!/usr/bin/perl -w
use strict;
use warnings;
+use Test::Exception;
BEGIN {
use Test::Most;
@@ -11,7 +12,7 @@ BEGIN {
plan skip_all => "Skipping all tests because VRTrack tests have not been configured";
}
else {
- plan tests => 134;
+ plan tests => 149;
}
use_ok('VRTrack::VRTrack');
@@ -269,6 +270,34 @@ is $vrtrack->hierarchy_path_of_lane($vrlane), 'species/foo/lib_a', 'hierarchy_pa
# $ENV{DATA_HIERARCHY} = 'genus:species-subspecies:project:strain:sample:technology:library:lane';
# is $vrtrack->hierarchy_path_of_lane($vrlane) ,'genus/species_subspecies/Project_test2/Individual_test/sample_a/seq_tech_test/lib_a/lane_a', 'hierarchy_path_of_lane works with DATA_HIERARCHY set to all items';
+# test hierarchy_path_of_object
+$ENV{DATA_HIERARCHY} = 'projectssid:project:individual:sample:technology:library:lane';
+is $vrtrack->hierarchy_path_of_object($vrproj), '1111/Project_htest', 'hierarchy_path_of_object works for project';
+is $vrtrack->hierarchy_path_of_object($sample), '1111/Project_htest/Individual_test/sample_a', 'hierarchy_path_of_object works for sample';
+is $vrtrack->hierarchy_path_of_object($library), '1111/Project_htest/Individual_test/sample_a/seq_tech_test/lib_a', 'hierarchy_path_of_object works for library';
+is $vrtrack->hierarchy_path_of_object($vrlane), '1111/Project_htest/Individual_test/sample_a/seq_tech_test/lib_a/lane_a', 'hierarchy_path_of_object works for lane';
+
+$ENV{DATA_HIERARCHY} = 'projectssid:project:genus:species-subspecies:individual:sample:technology:library:lane';
+is $vrtrack->hierarchy_path_of_object($vrlane), undef, 'hierarchy_path_of_object returns undef if hierarchy cannot be built (no species data)';
+my $species = $ind->add_species('Genus species subspecies');
+$ind->update();
+is $ind->species->name(), 'Genus species subspecies', 'added species to individual';
+is $vrtrack->hierarchy_path_of_object($vrlane), '1111/Project_htest/Genus/species_subspecies/Individual_test/sample_a/seq_tech_test/lib_a/lane_a', 'hierarchy_path_of_object works with species data';
+$ENV{DATA_HIERARCHY} = 'TRACKING:genus:species-subspecies:strain:individual:project:projectid:projectssid:sample:technology:library:lane';
+is $vrtrack->hierarchy_path_of_object($vrproj), undef, 'hierarchy_path_of_object returns undef if hierarchy cannot be built (impossible structure)';
+is $vrtrack->hierarchy_path_of_object($vrlane), 'TRACKING/Genus/species_subspecies/Individual_test/Individual_test/Project_htest/1/1111/sample_a/seq_tech_test/lib_a/lane_a', 'hierarchy_path_of_object finds all hierarchy terms';
+
+delete $ENV{DATA_HIERARCHY};
+is $vrtrack->hierarchy_path_of_object($vrlane), 'Project_htest/sample_a/seq_tech_test/lib_a/lane_a', 'hierarchy_path_of_object defaults to project:sample:technology:library:lane';
+$ENV{DATA_HIERARCHY} = 'project:genus:species-subspecies:sample:lane';
+is $vrtrack->hierarchy_path_of_object($vrlane, 'SUPPLIED_HIERARCHY:project:sample:lane'), 'SUPPLIED_HIERARCHY/Project_htest/sample_a/lane_a', 'hierarchy_path_of_object works for hierarchy supplied as parameter';
+
+throws_ok { $vrtrack->hierarchy_path_of_object($ind) } qr/A recognised object type must be supplied/, 'hierarchy_path_of_object throws for VRTrack::Individual';
+throws_ok { $vrtrack->hierarchy_path_of_object($species) } qr/A recognised object type must be supplied/, 'hierarchy_path_of_object throws for VRTrack::Species';
+throws_ok { $vrtrack->hierarchy_path_of_object('scalar') } qr/A recognised object type must be supplied/, 'hierarchy_path_of_object throws for unrecognised object';
+throws_ok { $vrtrack->hierarchy_path_of_object(undef) } qr/A recognised object type must be supplied/, 'hierarchy_path_of_object throws for undef object';
+
+
# test descendants using lane
$vrlane->update;
my @children = @{$vrlane->descendants};
View
0  web_code/lookseq/lookseq.html 100644 → 100755
File mode changed
View
1  web_code/lookseq/lookseq.js 100644 → 100755
@@ -1046,6 +1046,7 @@ function initialize_display () {
document.getElementById('display_annotation').checked = b['annotation'] ? true : false ;
document.getElementById('display_gc').checked = b['gc'] ? true : false ;
document.getElementById('display_coverage').checked = b['coverage'] ? true : false ;
+ document.getElementById('show_arrows').checked = b['orientation'] ? true : false ;
if ( indel_zoom != 'auto' ) document.getElementById('indel_zoom').value = indel_zoom ;
}
View
149 web_code/map-view/map_lanes_view.pl
@@ -0,0 +1,149 @@
+#!/usr/local/bin/perl -T
+
+BEGIN {
+ $ENV{VRTRACK_HOST} = 'mcs4a';
+ $ENV{VRTRACK_PORT} = 3306;
+ $ENV{VRTRACK_RO_USER} = 'vreseq_ro';
+ $ENV{VRTRACK_RW_USER} = 'vreseq_rw';
+ $ENV{VRTRACK_PASSWORD} = 't3aml3ss';
+};
+
+use strict;
+use warnings;
+use URI;
+
+use SangerPaths qw(core team145);
+use SangerWeb;
+use VRTrack::VRTrack;
+use VRTrack::Project;
+use VertRes::Utils::VRTrackFactory;
+use VertRes::QCGrind::ViewUtil;
+
+my $utl = VertRes::QCGrind::ViewUtil->new();
+
+my $title = 'Map View';
+
+my $sw = SangerWeb->new({
+ 'title' => $title,
+ 'banner' => q(),
+ 'inifile' => SangerWeb->document_root() . q(/Info/header.ini),
+ 'jsfile' => ['http://jsdev.sanger.ac.uk/prototype.js','http://jsdev.sanger.ac.uk/toggle.js','ttp://jsdev.sanger.ac.uk/scriptaculous/scriptaculous.js','http://jsdev.sanger.ac.uk/sidebar.js','http://jsdev.sanger.ac.uk/urchin.js','http://jsdev.sanger.ac.uk/zebra.js','http://js.sanger.ac.uk/sorttable_v2.js',],
+ 'style' => $utl->{CSS},
+});
+
+my $cgi = $sw->cgi();
+
+my $db = $cgi->param('db');
+my $pid = $cgi->param('proj_id');
+
+unless ($db) {
+ print $sw->header();
+ $utl->displayError( "No database ID",$sw );
+}
+my $vrtrack = $utl->connectToDatabase($db);
+
+$utl->displayError( "No Project ID",$sw ) unless $pid;
+
+print $sw->header();
+displayProjectLanesPage($cgi,$vrtrack,$db,$pid);
+print $sw->footer();
+exit;
+
+#######
+
+sub displayProjectLanesPage
+{
+ my ($cgi, $vrtrack, $database, $projectID) = @_;
+
+ my $init_script = $utl->{SCRIPTS}{MAP_VIEW};
+ my $qcgrind_script = $utl->{SCRIPTS}{QCGRIND_LANE};
+ my $project = VRTrack::Project->new( $vrtrack, $projectID );
+ displayError( "Cant get project: $projectID" ) unless $project;
+
+ my $samples = $project->samples();
+ displayError( "Cant get samples for project: $projectID" ) unless $samples;
+
+ my $pname = $project->name;
+ print qq[
+ <h2 align="center" style="font: normal 900 1.5em arial"><a href="$init_script">Map View</a></h2>
+ <h3 align="center" style="font: normal 700 1.5em arial">Project: $pname</h3>
+ ];
+
+ print qq[
+ <div class="centerFieldset">
+ <fieldset >
+ <legend>Lane data</legend>
+ <table width="60%">
+ <tr>
+ <th>Library</th>
+ <th>Improved</th>
+ <th>Called</th>
+ <th>Name</th>
+ ];
+
+ my @lanes;
+ my %mappers;
+ foreach( sort { $a->ssid() <=> $b->ssid() } @$samples)
+ {
+ my @libraries = sort {$a->name cmp $b->name} @{$_->libraries()};
+ foreach( @libraries )
+ {
+ my $library = $_;
+ my @lanes_ = @{ $library->lanes() };
+ foreach my $lane ( @lanes_ )
+ {
+ push( @lanes, $lane );
+ my @mapstats = @{ $lane->mappings() };
+ foreach my $mapstat (@mapstats)
+ {
+ if( $mapstat->mapper() )
+ {
+ my $mapper = $mapstat->mapper();
+ $mappers{ $mapper->name().qq[ v].$mapper->version() } = 1;
+ }
+ }
+ }
+ }
+ }
+
+ foreach my $mname ( sort( keys( %mappers ) ) )
+ {
+ print qq[<th>$mname</th>];
+ }
+ print qq[</tr>];
+
+ foreach my $lane ( @lanes )
+ {
+ print qq[<tr>];
+ my $id = $lane->id();
+ my $library = VRTrack::Library->new($vrtrack, $lane->library_id());
+ my $libName = $library->name();
+ my $improved = $lane->is_processed('improved') ? 'yes' : 'no';
+ my $called = $lane->is_processed('snp_called') ? 'yes' : 'no';
+ print qq[<td>$libName</td><td>$improved</td><td>$called</td><td><a href="$qcgrind_script?lane_id=$id&db=$database">].$lane->name().qq[</a></td>];
+ my @mappings = @{ $lane->mappings() };
+ my %lane_mappers;
+ foreach my $mapstat ( @mappings )
+ {
+ if( $mapstat->mapper() && $mapstat->raw_bases() && $mapstat->raw_bases() > 0 )
+ {
+ my $mapper = $mapstat->mapper();
+ $lane_mappers{ $mapper->name().qq[ v].$mapper->version() } = 1;
+ }
+ }
+ foreach my $mapper ( sort( keys( %mappers ) ) )
+ {
+ if( $lane_mappers{ $mapper } )
+ {
+ print qq[<td>yes</td>];
+ }
+ else{print qq[<td>no</td>];}
+ }
+ print qq[</tr>];
+ }
+ print qq[
+ </table>
+ </fieldset>
+ </div>
+ ];
+}
View
51 web_code/map-view/map_projects_view.pl
@@ -0,0 +1,51 @@
+#!/usr/local/bin/perl -T
+
+BEGIN {
+ $ENV{VRTRACK_HOST} = 'mcs4a';
+ $ENV{VRTRACK_PORT} = 3306;
+ $ENV{VRTRACK_RO_USER} = 'vreseq_ro';
+ $ENV{VRTRACK_RW_USER} = 'vreseq_rw';
+ $ENV{VRTRACK_PASSWORD} = 't3aml3ss';
+};
+
+use strict;
+use warnings;
+use URI;
+
+use SangerPaths qw(core team145);
+use SangerWeb;
+use VRTrack::VRTrack;
+use VRTrack::Project;
+use VertRes::Utils::VRTrackFactory;
+use VertRes::QCGrind::ViewUtil;
+
+my $utl = VertRes::QCGrind::ViewUtil->new();
+
+my $title = 'Map View';
+
+my $sw = SangerWeb->new({
+ 'title' => $title,
+ 'banner' => q(),
+ 'inifile' => SangerWeb->document_root() . q(/Info/header.ini),
+});
+
+my $cgi = $sw->cgi();
+
+my $db = $cgi->param('db');
+unless ($db) {
+ print $sw->header();
+ $utl->displayError( "No database ID",$sw );
+}
+my $vrtrack = $utl->connectToDatabase($db);
+unless ( defined $vrtrack ) {
+ print $sw->header();
+ $utl->displayError( "No database connection to $db",$sw );
+}
+
+my $init_script = $utl->{SCRIPTS}{MAP_VIEW};
+my $lanes_script = $utl->{SCRIPTS}{MAP_LANES_VIEW};
+
+print $sw->header();
+$utl->displayDatabasePage($title,$cgi,$vrtrack,$db,$init_script,$lanes_script);
+print $sw->footer();
+exit;
View
415 web_code/map-view/map_view.pl 100644 → 100755
@@ -1,413 +1,40 @@
#!/usr/local/bin/perl -T
-# Displays QC information for Sanger short-read sequencing to allow lanes
-# to be passed/failed
-#
-# Author: tk2
-# Maintainer: tk2
-# Created: 2011-03-12
+
+BEGIN {
+ $ENV{VRTRACK_HOST} = 'mcs4a';
+ $ENV{VRTRACK_PORT} = 3306;
+ $ENV{VRTRACK_RO_USER} = 'vreseq_ro';
+ $ENV{VRTRACK_RW_USER} = 'vreseq_rw';
+ $ENV{VRTRACK_PASSWORD} = 't3aml3ss';
+};
use strict;
use warnings;
use URI;
-use lib '.';
-#use SangerPaths qw(core team145);
-use SangerPaths qw(core);
-use lib './modules';
-use VRTrack::VRTrack;
-use VRTrack::Project;
-use VRTrack::Sample;
-use VRTrack::Library;
-use VRTrack::Lane;
-use VertRes::Utils::VRTrackFactory;
-use Data::Dumper;
-
+use SangerPaths qw(core team145);
use SangerWeb;
-$ENV{PATH}= '/usr/local/bin'; # solely to stop taint from barfing
-
-$|++;
-
-#different modes/views possible
-my $ERROR_DISPLAY = 0;
-my $PROJ_VIEW = 1;
-my $DB_VIEW = 2;
-
-###############################CSS Stuff#############################
-
-my $css = <<CSS ;
-
-.centerFieldset {
-text-align:center;
-}
-
-.centerFieldset fieldset {
-margin-left:auto;
-margin-right:auto;
-/* INHERITED ALIGNMENT IS CENTER. ONLY INCLUDE THIS IF YOU WANT */
-/* TO CHANGE THE ALIGNMENT OF THE CONTENTS OF THE FIELDSET */
-text-align:left;
-}
-
-.centerFieldset table {
- margin-left:auto;
- margin-right:auto;
-}
-
-table.summary {
- border-collapse: collapse;
- font: 0.9em Verdana, Arial, Helvetica, sans-serif;
-}
-
-table.summary td {
- white-space: nowrap;
- text-align: right;
- padding-right: 1em;
- padding-left: 1em;
- padding-top: 2px;
- padding-bottom: 2px;
- border-bottom: #83a4c3 dotted 1px;
-}
-
-table.summary tr.header th, table.summary tr.header td {
- font-weight:bold;
- border-bottom: #83a4c3 solid 1px;
- text-align: left;
- vertical-align:middle;
-}
-
-table.summary tr.level th, table.summary tr.level td {
- font-weight:bold;
- border-bottom: #83a4c3 dotted 1px;
- text-align: left;
- vertical-align:middle;
-}
-
-table.summary tr.total th, table.summary tr.total td {
- font-weight:bold;
- background-color: #CBDCED;
- border-bottom: #83a4c3 dotted 1px;
- text-align: right;
- vertical-align:middle;
-}
-
-
-
-input.btn {
- font: bold 150% 'trebuchet ms',helvetica,sans-serif;
- border:1px solid;
- border-color: #707070 #000 #000 #707070;
-}
-
-input.btnhov {
- cursor:pointer;
- border-color: #c63 #930 #930 #c63;
-}
-
-.clear
-{
- clear: both;
- display: block;
- overflow: hidden;
- visibility: hidden;
- width: 0;
- height: 0;
-}
-
-img.preview:hover {
- width: 480px;
- height: 480px;
-}
-
-.thumbnail{
-position: relative;
-z-index: 0;
-}
-
-.thumbnail:hover{
-background-color: transparent;
-z-index: 50;
-}
-
-.thumbnail span{ /*CSS for enlarged image*/
-position: absolute;
-padding: 5px;
-left: -1000px;
-visibility: hidden;
-text-decoration: none;
-}
-
-.thumbnail span img{ /*CSS for enlarged image*/
-border-width: 0;
-padding: 2px;
-}
-
-.thumbnail:hover span{ /*CSS for enlarged image on hover*/
-visibility: visible;
-top: 0;
-left: -480px; /*position where enlarged image should offset horizontally */
+use VertRes::Utils::VRTrackFactory;
+use VertRes::QCGrind::ViewUtil;
-}
+my $utl = VertRes::QCGrind::ViewUtil->new();
-CSS
+my $title = 'Map View';
my $sw = SangerWeb->new({
- 'title' => q(Map View v1),
+ 'title' => $title,
'banner' => q(),
'inifile' => SangerWeb->document_root() . q(/Info/header.ini),
- 'style' => $css,
+ 'jsfile' => ['http://jsdev.sanger.ac.uk/prototype.js','http://jsdev.sanger.ac.uk/jquery-1.4.2.min.js','http://www.sanger.ac.uk/modelorgs/mousegenomes/jquery.coolfieldset.js'],
+ 'style' => $utl->{CSS},
});
-#script name for self links
my $cgi = $sw->cgi();
-my $SCRIPT_NAME = $cgi->url(-relative=>1);
-
-#decide on the entry point
-my $mode = $cgi->param('mode');
-
-if( defined( $mode ) && $mode == $ERROR_DISPLAY )
-{
- my $message = $cgi->param('error_msg');
-
- print $sw->header();
- displayError( $message );
- print $sw->footer();
-
- exit;
-}
-
-# List available databases.
-if( !defined( $cgi->param('db')) ) {
- print $sw->header();
- displayDatabasesPage();
- print $sw->footer();
- exit;
-}
-
-# All other entry points require a database
-my $db = $cgi->param('db');
-if( ! defined $db ) {
- redirectErrorScreen( $cgi, "Database must be defined!" );
- exit;
-}
-
-if( ! isDatabase( $db ) ) {
- redirectErrorScreen( $cgi, "Invalid database name!" );
- exit;
-}
-
-my $vrtrack = connectToDatabase( $db );
-redirectErrorScreen( $cgi, "Failed to connect to database: $db" ) unless defined( $vrtrack );
-
-if( $mode == $DB_VIEW )
-{
- print $sw->header();
- displayDatabasePage( $cgi, $vrtrack, $db );
- print $sw->footer();
- exit;
-}
-elsif( $mode == $PROJ_VIEW )
-{
- my $pid = $cgi->param('proj_id');
- if( ! defined( $pid ) )
- {
- redirectErrorScreen( $cgi, "Must provide a project ID" );
- exit;
- }
-
- print $sw->header();
- displayProjectLanesPage($cgi, $vrtrack, $db, $pid);
- print $sw->footer();
- exit;
-}
-else
-{
- redirectErrorScreen( $cgi, "Invalid mode!" );
-}
-
-sub displayDatabasesPage
-{
- print qq[
- <h2 align="center" style="font: normal 900 1.5em arial">Map View</h2>
- <div class="centerFieldset">
- <fieldset style="width: 500px">
- <legend>Select dataset to View</legend>
- ];
-
- my @dbs = VertRes::Utils::VRTrackFactory->databases(1);
- foreach( @dbs )
- {
- print qq[
- <p><a href="$SCRIPT_NAME?mode=$DB_VIEW&amp;db=$_">].$_.qq[</a></p>
- ];
- }
-
- print qq[
- </fieldset>
- </div>
- ];
-}
-
-sub displayDatabasePage
-{
- my $cgi = shift;
- my $vrtrack = shift;
- my $db = shift;
- print qq[
- <h2 align="center" style="font: normal 900 1.5em arial"><a href="$SCRIPT_NAME">Map View</a></h2>
- <div class="centerFieldset">
- <fieldset style="width: 500px">
- <legend>Select study to View</legend>
- ];
-
- my @projects = @{ $vrtrack->projects() };
- foreach my $project (@projects)
- {
- my $id = $project->id();
- print qq[
- <p><a href="$SCRIPT_NAME?mode=$PROJ_VIEW&amp;proj_id=$id&amp;db=$db">].$project->name().qq[</a></p>
- ];
- }
-
- print qq[
- </fieldset>
- </div>
- ];
-}
-
-sub displayProjectLanesPage
-{
- my ($cgi, $vrtrack, $database, $projectID) = @_;
-
- my $project = VRTrack::Project->new( $vrtrack, $projectID );
- displayError( "Cant get project: $projectID" ) unless $project;
-
- my $samples = $project->samples();
- displayError( "Cant get samples for project: $projectID" ) unless $samples;
-
- my $pname = $project->name;
- print qq[
- <h2 align="center" style="font: normal 900 1.5em arial"><a href="$SCRIPT_NAME">Map View</a></h2>
- ];
-
- print qq[
- <div class="centerFieldset">
- <fieldset >
- <legend>Lane data</legend>
- <table width="60%">
- <tr>
- <th>Library</th>
- <th>Improved</th>
- <th>Called</th>
- <th>Name</th>
- ];
-
- my @lanes;
- my %mappers;
- foreach( sort { $a->ssid() <=> $b->ssid() } @$samples)
- {
- my @libraries = sort {$a->name cmp $b->name} @{$_->libraries()};
- foreach( @libraries )
- {
- my $library = $_;
- my @lanes_ = @{ $library->lanes() };
- foreach my $lane ( @lanes_ )
- {
- push( @lanes, $lane );
- my @mapstats = @{ $lane->mappings() };
- foreach my $mapstat (@mapstats)
- {
-# print $mapstat->mapper()->name();exit;
- if( $mapstat->mapper() )
- {
- my $mapper = $mapstat->mapper();
- $mappers{ $mapper->name().qq[ v].$mapper->version() } = 1;
- }
- }
- }
- }
- }
-
- foreach my $mname ( sort( keys( %mappers ) ) )
- {
- print qq[<th>$mname</th>];
- }
- print qq[</tr>];
-
- foreach my $lane ( @lanes )
- {
- print qq[<tr>];
- my $id = $lane->id();
- my $library = VRTrack::Library->new($vrtrack, $lane->library_id());my $libName = $library->name();
- my $improved = $lane->is_processed('improved') ? 'yes' : 'no';
- my $called = $lane->is_processed('snp_called') ? 'yes' : 'no';
- print qq[<td>$libName</td><td>$improved</td><td>$called</td><td><a href="http://intwebdev.sanger.ac.uk/cgi-bin/teams/team145/qc_grind/qc_grind.pl?mode=0&lane_id=$id&db=$database">].$lane->name().qq[</a></td>];
- my @mappings = @{ $lane->mappings() };
- my %lane_mappers;
- foreach my $mapstat ( @mappings )
- {
- if( $mapstat->mapper() && $mapstat->raw_bases() && $mapstat->raw_bases() > 0 )
- {
- my $mapper = $mapstat->mapper();
- $lane_mappers{ $mapper->name().qq[ v].$mapper->version() } = 1;
- }
- }
- foreach my $mapper ( sort( keys( %mappers ) ) )
- {
- if( $lane_mappers{ $mapper } )
- {
- print qq[<td>yes</td>];
- }
- else{print qq[<td>no</td>];}
- }
- print qq[</tr>];
- }
- print qq[
- </table>
- </fieldset>
- </div>
- ];
-}
-
-sub isDatabase
-{
- my $db = shift;
-
- my @dbs = VertRes::Utils::VRTrackFactory->databases(1);
- foreach( @dbs ){if( $db eq $_ ){return 1;}}
- return 0;
-}
-sub displayError
-{
- my $message = $_[ 0 ];
-
- print qq[<h2>A problem occurred</h2>\n];
- print qq[<p class="error1">$message</p>\n];
- print $sw->footer();
- exit;
-}
+my $script = $utl->{SCRIPTS}{MAP_PROJECTS_VIEW};
-sub connectToDatabase
-{
- my $database = $_[ 0 ];
- my $vrtrack = VertRes::Utils::VRTrackFactory->instantiate(database => $db,
- mode => 'rw');
- return $vrtrack;
-}
+print $sw->header();
+$utl->displayDatabasesPage($title,$cgi,$script,1);
+print $sw->footer();
+exit;
-sub redirectErrorScreen
-{
- my $cgi = $_[ 0 ];
- my $error = 'An unknown error occurred';
- if( @_ == 2 )
- {
- $error = $_[ 1 ];
- }
-
- my $location = "$SCRIPT_NAME?mode=$ERROR_DISPLAY&amp;error_msg=$error";
- #print $cgi->header();
- #print "window.location=\"$location\";\n\n";
- print $cgi->redirect( -URL => $location, -method => 'GET', -status => 302 );
- #print "Location: $location";
- exit;
-}
View
191 web_code/pending-view/pending_requests_view.pl
@@ -0,0 +1,191 @@
+#!/usr/local/bin/perl -T
+
+BEGIN {
+ $ENV{VRTRACK_HOST} = 'mcs4a';
+ $ENV{VRTRACK_PORT} = 3306;
+ $ENV{VRTRACK_RO_USER} = 'vreseq_ro';
+ $ENV{VRTRACK_RW_USER} = 'vreseq_rw';
+ $ENV{VRTRACK_PASSWORD} = 't3aml3ss';
+};
+
+use strict;
+use warnings;
+use URI;
+
+use SangerPaths qw(core team145);
+use SangerWeb;
+use VRTrack::VRTrack;
+use VRTrack::Project;
+use VRTrack::Sample;
+use VRTrack::Library;
+use VRTrack::Lane;
+use VRTrack::Multiplex_pool;
+use VertRes::Utils::VRTrackFactory;
+use VertRes::QCGrind::ViewUtil;
+
+my $utl = VertRes::QCGrind::ViewUtil->new();
+
+my $title = 'Pending View';
+
+my $sw = SangerWeb->new({
+ 'title' => $title,
+ 'banner' => q(),
+ 'inifile' => SangerWeb->document_root() . q(/Info/header.ini),
+ 'style' => $utl->{CSS},
+});
+
+my $cgi = $sw->cgi();
+
+my $db = $cgi->param('db');
+unless ($db) {
+ print $sw->header();
+ $utl->displayError( "No database ID",$sw );
+}
+my $vrtrack = $utl->connectToDatabase($db);
+unless ( defined $vrtrack ) {
+ print $sw->header();
+ $utl->displayError( "No database connection to $db",$sw );
+}
+
+print $sw->header();
+displayPendingRequestsPage($cgi,$vrtrack,$db);
+print $sw->footer();
+exit;
+
+#######
+
+
+sub displayPendingRequestsPage
+{
+ my $cgi = shift;
+ my $vrtrack = shift;
+ my $db = shift;
+
+ my $init_script = $utl->{SCRIPTS}{PENDING_VIEW};
+
+ my @projects = sort {$a->name cmp $b->name} @{$vrtrack->projects()};
+
+ my @libpendings;
+ my @libstarted;
+ my @seqpendings;
+ my @seqstarted;
+ my @mplexpendings;
+ my @mplexstarted;
+ my $lib_type = "library";
+ my $seq_type = "sequence";
+ my $plex_type = "multiplex sequence";
+
+ print qq[
+ <h2 align="center" style="font: normal 900 1.5em arial"><a href="$init_script">Pending Requests</a></h2>
+
+ <div class="centerFieldset">
+ ];
+
+ foreach my $project (@projects)
+ {
+ my $projectID = $project->id();
+
+ my $samples = $project->samples();
+ displayError( "Cant get samples for project: $projectID" ) unless $samples;
+
+ my $pname = $project->name;
+
+ my $pendingflag = 'pending';
+ my $startedflag = 'started';
+
+ foreach( @{$samples} )
+ {
+ my $sample = $_;
+ my $sname = $sample->name();
+ my $library_requests = $sample->library_requests();
+ foreach ( @{$library_requests}) {
+ my $librequest = $_;
+ my $lib_status = $librequest->prep_status();
+ my $lib_date = $librequest->changed();
+ my $ssid = $librequest->ssid();
+ if ($lib_status eq $pendingflag) { push @libpendings, [$projectID, $pname, $sname, $lib_status, $lib_date, $ssid]; }
+ elsif ($lib_status eq $startedflag) { push @libstarted, [$projectID, $pname, $sname, $lib_status, $lib_date, $ssid]; }
+ }
+ my $libraries = $sample->libraries();
+ foreach ( @{$libraries}) {
+ my $library = $_;
+ my $seq_requests = $library->seq_requests();
+ foreach ( @{$seq_requests} ) {
+ my $seqrequest = $_;
+ my $seq_status = $seqrequest->seq_status();
+ my $seq_date = $seqrequest->changed();
+ my $ssid = $seqrequest->ssid();
+ if ($seq_status eq $pendingflag) { push @seqpendings, [$projectID, $pname, $sname, $seq_status, $seq_date, $ssid];}
+ elsif ($seq_status eq $startedflag) { push @seqstarted, [$projectID, $pname, $sname, $seq_status, $seq_date, $ssid];}
+ }
+ foreach ( @{$library->library_multiplex_pools}){
+ my $mplex = VRTrack::Multiplex_pool->new($vrtrack, $_->multiplex_pool_id);
+ foreach ( @{ $mplex->seq_requests } ){
+ my $seqrequest = $_;
+ my $seq_status = $seqrequest->seq_status();
+ my $seq_date = $seqrequest->changed();
+ my $ssid = $seqrequest->ssid();
+ if ($seq_status eq $pendingflag) { push @mplexpendings, [$projectID, $pname, $sname, $seq_status, $seq_date, $ssid]; }
+ if ($seq_status eq $startedflag) { push @mplexstarted, [$projectID, $pname, $sname, $seq_status, $seq_date, $ssid]; }
+ }
+ }
+ @mplexpendings = sort {$a->[5] <=> $b->[5]} @mplexpendings;
+ @mplexstarted = sort {$a->[5] <=> $b->[5]} @mplexstarted;
+ }
+ }
+ }
+ my @libtotal = (@libpendings, @libstarted);
+ my @seqtotal = (@seqpendings, @seqstarted);
+ my @mplextotal = (@mplexpendings, @mplexstarted);
+ printPendingRows(\@libtotal, $lib_type, $db, $cgi);
+ printPendingRows(\@seqtotal, $seq_type, $db, $cgi);
+ printPendingRows(\@mplextotal, $plex_type, $db, $cgi);
+ print qq[
+ </div>
+ ];
+}
+
+sub printPendingRows
+{
+ my ($pendinglist, $req_type, $db, $cgi) = @_;
+ my $qcgrind_script = $utl->{SCRIPTS}{QCGRIND_SAMPLES};
+ print qq[
+ <fieldset >
+ <legend>Pending $req_type requests</legend>
+ <table width="80%">
+ <tr>
+ <th>QC Link</th>
+ <th>Project</th>
+ <th>Sample Name</th>
+ <th>Status</th>
+ <th>Date changed</th>
+ <th>SSID</th>
+ </tr>
+ ];
+ my @pendings = @$pendinglist;
+ my $current_project = '';
+ if (@pendings) {
+ for my $i ( 0 .. $#pendings ) {
+ my @pending = @{$pendings[$i]};
+ print qq[<tr>];
+ if ($current_project ne $pending[1]) {
+ print qq[<td><a href="$qcgrind_script?db=$db&amp;proj_id=$pending[0]">QC_grind</a></td>];
+ $current_project = $pending[1];
+ }
+ else {
+ print qq[<td></td>];
+ }
+ for my $j ( 1 .. ($#pending-1) ) {
+ print qq[<td>$pending[$j]</td>];
+ }
+ print qq[<td><a href="http://psd-production.internal.sanger.ac.uk:6600/requests/$pending[$#pending]">$pending[$#pending]</a></td></tr>];
+ }
+ }
+ else {
+ print qq[<tr><td colspan=5>No pending $req_type requests were found in the $db database.</td></tr>];
+ }
+ print qq[
+ </table>
+ </fieldset><br/>
+ ];
+}
View
430 web_code/pending-view/pending_view.pl
@@ -1,427 +1,39 @@
#!/usr/local/bin/perl -T
-# Displays pending sequencing requests
-#
-# Author: tk2/jm23
-# Maintainer: ??
-# Created: 2011-04-08
+
+BEGIN {
+ $ENV{VRTRACK_HOST} = 'mcs4a';
+ $ENV{VRTRACK_PORT} = 3306;
+ $ENV{VRTRACK_RO_USER} = 'vreseq_ro';
+ $ENV{VRTRACK_RW_USER} = 'vreseq_rw';
+ $ENV{VRTRACK_PASSWORD} = 't3aml3ss';
+};
use strict;
use warnings;
use URI;
-use lib '.';
-#use SangerPaths qw(core team145);
-use SangerPaths qw(core);
-use lib './modules';
-use VRTrack::VRTrack;
-use VRTrack::Project;
-use VRTrack::Sample;
-use VRTrack::Library;
-use VRTrack::Lane;
-use VRTrack::Multiplex_pool;
-use VertRes::Utils::VRTrackFactory;
-use Data::Dumper;
-
+use SangerPaths qw(core team145);
use SangerWeb;
-$ENV{PATH}= '/usr/local/bin'; # solely to stop taint from barfing
-
-$|++;
-
-#different modes/views possible
-my $ERROR_DISPLAY = 0;
-my $PROJ_VIEW = 1;
-my $DB_VIEW = 2;
-
-###############################CSS Stuff#############################
-
-my $css = <<CSS ;
-
-.centerFieldset {
-text-align:center;
-}
-
-.centerFieldset fieldset {
-margin-left:auto;
-margin-right:auto;
-/* INHERITED ALIGNMENT IS CENTER. ONLY INCLUDE THIS IF YOU WANT */
-/* TO CHANGE THE ALIGNMENT OF THE CONTENTS OF THE FIELDSET */
-text-align:left;
-}
-
-.centerFieldset table {
- margin-left:auto;
- margin-right:auto;
-}
-
-table.summary {
- border-collapse: collapse;
- font: 0.9em Verdana, Arial, Helvetica, sans-serif;
-}
-
-table.summary td {
- white-space: nowrap;
- text-align: right;
- padding-right: 1em;
- padding-left: 1em;
- padding-top: 2px;
- padding-bottom: 2px;
- border-bottom: #83a4c3 dotted 1px;
-}
-
-table.summary tr.header th, table.summary tr.header td {
- font-weight:bold;
- border-bottom: #83a4c3 solid 1px;
- text-align: left;
- vertical-align:middle;
-}
-
-table.summary tr.level th, table.summary tr.level td {
- font-weight:bold;
- border-bottom: #83a4c3 dotted 1px;
- text-align: left;
- vertical-align:middle;
-}
-
-table.summary tr.total th, table.summary tr.total td {
- font-weight:bold;
- background-color: #CBDCED;
- border-bottom: #83a4c3 dotted 1px;
- text-align: right;
- vertical-align:middle;