Skip to content

Commit ef3b8b1

Browse files
lukasmuellerlukasmueller
authored
Merge pull request #6093 from solgenomics/topic/env_stratification
Environment stratification tool
2 parents 0f5d643 + 63724a1 commit ef3b8b1

11 files changed

Lines changed: 1899 additions & 10 deletions

File tree

‎R/environment_stratification.R‎

Lines changed: 708 additions & 0 deletions
Large diffs are not rendered by default.

‎js/source/entries/environments.js‎

Lines changed: 633 additions & 0 deletions
Large diffs are not rendered by default.

‎js/source/legacy/solGS/analysisSelect.js‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -190,6 +190,12 @@ jQuery(document).ready(function () {
190190
jQuery(corrMsgDiv).html("Running correlation... please wait...").show();
191191

192192
solGS.correlation.runPhenoCorrelation(corrArgs).done(function (res) {
193+
if (res.error) {
194+
jQuery(`${canvas} .multi-spinner-container`).hide();
195+
jQuery(corrMsgDiv).html(res.error).show();
196+
return;
197+
}
198+
193199
if (res.corr_output_data) {
194200
corrArgs["corr_table_file"] = res.corre_table_file;
195201
var corrDownload = solGS.correlation.createCorrDownloadLink(corrArgs);

‎lib/CXGN/Dataset.pm‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1300,6 +1300,9 @@ sub calculate_tool_compatibility {
13001300
'Correlation' => {
13011301
'compatible' => 0
13021302
},
1303+
'Environment Stratification' => {
1304+
'compatible' => 0
1305+
},
13031306
'NIRS' => {
13041307
'compatible' => 0
13051308
},
@@ -1344,6 +1347,12 @@ sub calculate_tool_compatibility {
13441347
}
13451348
}
13461349

1350+
push @{$tool_compatibility->{"Environment Stratification"}->{"dataset requirements"}}, "Trials : ".scalar(@{$trials});
1351+
push @{$tool_compatibility->{"Environment Stratification"}->{"dataset requirements"}}, "Traits : ".scalar(@{$all_traits});
1352+
if (scalar(@{$trials}) > 1 && scalar(@{$all_traits}) > 0) {
1353+
$tool_compatibility->{"Environment Stratification"}->{"compatible"} = 1;
1354+
}
1355+
13471356
my $trial_designs = $self->retrieve_trial_designs();
13481357
my $genotyping_methods = $self->retrieve_genotyping_protocols();# listref of listrefs. First index is
13491358
# method ID, second is method name

‎lib/SGN/Controller/AJAX/EnvironmentStratification.pm‎

Lines changed: 324 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,324 @@
1+
use strict;
2+
3+
package SGN::Controller::AJAX::EnvironmentStratification;
4+
5+
use Moose;
6+
use File::Temp qw | tempfile |;
7+
use File::Slurp qw | read_file |;
8+
use File::Basename qw | basename |;
9+
use File::Copy;
10+
use File::Spec qw | catfile |;
11+
use CXGN::Dataset;
12+
use CXGN::Dataset::File;
13+
use CXGN::Job;
14+
use JSON::Any;
15+
16+
BEGIN { extends 'Catalyst::Controller::REST' }
17+
18+
__PACKAGE__->config(
19+
default => 'application/json',
20+
stash_key => 'rest',
21+
map => { 'application/json' => 'JSON' },
22+
);
23+
24+
sub shared_phenotypes : Path('/ajax/environment_stratification/shared_phenotypes') : {
25+
my $self = shift;
26+
my $c = shift;
27+
my $dataset_id = $c->req->param('dataset_id');
28+
my $exclude_outliers = $c->req->param('dataset_trait_outliers') || 0;
29+
30+
if (!$dataset_id) {
31+
$c->stash->{rest} = { error => 'Dataset id is required.' };
32+
return;
33+
}
34+
35+
my $sp_person_id = $c->user() ? $c->user->get_object()->get_sp_person_id() : undef;
36+
my $people_schema = $c->dbic_schema("CXGN::People::Schema", undef, $sp_person_id);
37+
my $schema = $c->dbic_schema("Bio::Chado::Schema", "sgn_chado", $sp_person_id);
38+
39+
my $ds = CXGN::Dataset->new(
40+
people_schema => $people_schema,
41+
schema => $schema,
42+
sp_dataset_id => $dataset_id,
43+
);
44+
my $traits = $ds->retrieve_traits();
45+
46+
$c->tempfiles_subdir("environment_stratification_files");
47+
my ($fh, $tempfile) = $c->tempfile(TEMPLATE => "environment_stratification_files/trait_XXXXX");
48+
my $temppath = $c->config->{basepath} . "/" . $tempfile;
49+
50+
my $ds_file = CXGN::Dataset::File->new(
51+
people_schema => $people_schema,
52+
schema => $schema,
53+
sp_dataset_id => $dataset_id,
54+
exclude_dataset_outliers => $exclude_outliers,
55+
exclude_phenotype_outlier => $exclude_outliers,
56+
file_name => $temppath,
57+
quotes => 0,
58+
);
59+
$ds_file->retrieve_phenotypes();
60+
61+
$c->stash->{rest} = {
62+
options => $traits,
63+
tempfile => $tempfile . "_phenotype.txt",
64+
};
65+
}
66+
67+
sub extract_trait_data : Path('/ajax/environment_stratification/getdata') Args(0) {
68+
my $self = shift;
69+
my $c = shift;
70+
71+
my $file = basename($c->req->param("file") || '');
72+
my $trait = $c->req->param("trait");
73+
74+
if (!$file) {
75+
$c->stash->{rest} = { error => "Phenotype file is required." };
76+
return;
77+
}
78+
79+
my $temppath = File::Spec->catfile($c->config->{basepath}, "static/documents/tempfiles/environment_stratification_files/" . $file);
80+
my $F;
81+
if (!open($F, "<", $temppath)) {
82+
$c->stash->{rest} = { error => "Can't find data." };
83+
return;
84+
}
85+
86+
my $header = <$F>;
87+
chomp($header);
88+
my @keys = split("\t", $header);
89+
for (my $n = 0; $n < @keys; $n++) {
90+
$keys[$n] =~ s/\|CO_.*// if $keys[$n] =~ /\|CO_/;
91+
}
92+
93+
my @data;
94+
while (<$F>) {
95+
chomp;
96+
my @fields = split "\t";
97+
my %line;
98+
for (my $n = 0; $n < @keys; $n++) {
99+
$line{$keys[$n]} = $fields[$n] if exists($fields[$n]) && defined($fields[$n]);
100+
}
101+
push @data, \%line;
102+
}
103+
104+
$c->stash->{rest} = { data => \@data, trait => $trait };
105+
}
106+
107+
sub generate_results : Path('/ajax/environment_stratification/generate_results') : {
108+
my $self = shift;
109+
my $c = shift;
110+
111+
my $dataset_id = $c->req->param('dataset_id');
112+
my $trait_id = $c->req->param('trait_id');
113+
my $alpha = $c->req->param('alpha') || 0.05;
114+
my $exclude_outliers = $c->req->param('dataset_trait_outliers') || 0;
115+
116+
if (!$dataset_id || !$trait_id) {
117+
$c->stash->{rest} = { error => 'Dataset and trait are required.' };
118+
return;
119+
}
120+
if ($alpha !~ /^\d*\.?\d+$/ || $alpha <= 0 || $alpha >= 1) {
121+
$c->stash->{rest} = { error => 'Alpha must be a number between 0 and 1.' };
122+
return;
123+
}
124+
125+
$c->tempfiles_subdir("environment_stratification_files");
126+
my $tmp_output_dir = $c->config->{cluster_shared_tempdir} . "/environment_stratification_files";
127+
mkdir $tmp_output_dir if !-d $tmp_output_dir;
128+
129+
my ($tmp_fh, $tempfile) = tempfile(
130+
"environment_stratification_XXXXX",
131+
DIR => $tmp_output_dir,
132+
);
133+
134+
my $pheno_filepath = $tempfile . "_phenotype.txt";
135+
my $pairwise_file = $tempfile . "_pairwise.json";
136+
my $group_summary_file = $tempfile . "_group_summary.json";
137+
my $group_membership_file = $tempfile . "_group_membership.json";
138+
my $ungrouped_file = $tempfile . "_ungrouped.json";
139+
my $summary_file = $tempfile . "_summary.json";
140+
my $anova_file = $tempfile . "_anova.json";
141+
my $message_file = $tempfile . "_message.txt";
142+
143+
my $sp_person_id = $c->user() ? $c->user->get_object()->get_sp_person_id() : undef;
144+
my $people_schema = $c->dbic_schema("CXGN::People::Schema", undef, $sp_person_id);
145+
my $schema = $c->dbic_schema("Bio::Chado::Schema", "sgn_chado", $sp_person_id);
146+
147+
my $ds = CXGN::Dataset::File->new(
148+
people_schema => $people_schema,
149+
schema => $schema,
150+
sp_dataset_id => $dataset_id,
151+
exclude_dataset_outliers => $exclude_outliers,
152+
exclude_phenotype_outlier => $exclude_outliers,
153+
file_name => $tempfile,
154+
quotes => 0,
155+
);
156+
$ds->retrieve_phenotypes($pheno_filepath);
157+
158+
my $r_trait = $trait_id;
159+
$r_trait =~ tr/ /\./;
160+
$r_trait =~ tr/\//\./;
161+
162+
my $cxgn_tools_run_config = {
163+
backend => $c->config->{backend},
164+
submit_host => $c->config->{cluster_host},
165+
temp_base => $tmp_output_dir,
166+
queue => $c->config->{'web_cluster_queue'},
167+
do_cleanup => 0,
168+
max_cluster_jobs => 1_000_000_000,
169+
};
170+
171+
my $cmd_str = join(" ", (
172+
"Rscript",
173+
map { _shell_quote($_) } (
174+
$c->config->{basepath} . "/R/environment_stratification.R",
175+
$pheno_filepath,
176+
$r_trait,
177+
$alpha,
178+
$pairwise_file,
179+
$group_summary_file,
180+
$group_membership_file,
181+
$ungrouped_file,
182+
$summary_file,
183+
$anova_file,
184+
$message_file,
185+
)
186+
));
187+
188+
my $user = $c->user() ? $c->user->get_object()->get_sp_person_id() : undef;
189+
my $job = CXGN::Job->new({
190+
schema => $schema,
191+
people_schema => $people_schema,
192+
sp_person_id => $user,
193+
name => $ds->name() . " environment stratification",
194+
job_type => 'environment_stratification',
195+
cmd => $cmd_str,
196+
cxgn_tools_run_config => $cxgn_tools_run_config,
197+
finish_logfile => $c->config->{job_finish_log},
198+
});
199+
200+
$job->submit();
201+
while ($job->alive()) {
202+
sleep(1);
203+
}
204+
205+
my $finished = $job->read_finish_timestamp();
206+
if (!$finished) {
207+
$job->update_status("failed");
208+
my $message = -e $message_file ? read_file($message_file) : 'Environment stratification failed before producing results.';
209+
$c->stash->{rest} = { error => $message };
210+
return;
211+
}
212+
$job->update_status("finished");
213+
214+
my $public_dir = $c->config->{basepath} . "/static/documents/tempfiles/environment_stratification_files";
215+
mkdir $public_dir if !-d $public_dir;
216+
217+
foreach my $file ($pairwise_file, $group_summary_file, $group_membership_file, $ungrouped_file, $summary_file, $anova_file, $message_file) {
218+
copy($file, $public_dir) if -e $file;
219+
}
220+
221+
my $json = JSON::Any->new;
222+
my $message = -e $message_file ? read_file($message_file) : 'Analysis finished.';
223+
224+
my $pairwise = _read_json_file($json, $pairwise_file);
225+
my $group_summary = _read_json_file($json, $group_summary_file);
226+
my $group_membership = _read_json_file($json, $group_membership_file);
227+
my $ungrouped = _read_json_file($json, $ungrouped_file);
228+
my $summary = _read_json_file($json, $summary_file);
229+
my $anova = _read_json_file($json, $anova_file);
230+
231+
$c->stash->{rest} = {
232+
message => $message,
233+
pairwise => $pairwise,
234+
group_summary => $group_summary,
235+
group_membership => $group_membership,
236+
ungrouped => $ungrouped,
237+
summary => $summary,
238+
anova => $anova,
239+
map_locations => _build_map_locations($schema, $group_membership, $ungrouped),
240+
files => {
241+
pairwise => "/documents/tempfiles/environment_stratification_files/" . basename($pairwise_file),
242+
group_summary => "/documents/tempfiles/environment_stratification_files/" . basename($group_summary_file),
243+
group_membership => "/documents/tempfiles/environment_stratification_files/" . basename($group_membership_file),
244+
ungrouped => "/documents/tempfiles/environment_stratification_files/" . basename($ungrouped_file),
245+
summary => "/documents/tempfiles/environment_stratification_files/" . basename($summary_file),
246+
anova => "/documents/tempfiles/environment_stratification_files/" . basename($anova_file),
247+
},
248+
};
249+
}
250+
251+
sub _read_json_file {
252+
my $json = shift;
253+
my $file = shift;
254+
255+
return [] if !$file || !-e $file;
256+
my $contents = read_file($file);
257+
return $json->decode($contents || '[]');
258+
}
259+
260+
sub _shell_quote {
261+
my $value = shift;
262+
my @parts = split(/'/, $value, -1);
263+
return "'" . join("'\"'\"'", @parts) . "'";
264+
}
265+
266+
sub _build_map_locations {
267+
my $schema = shift;
268+
my $group_membership = shift || [];
269+
my $ungrouped = shift || [];
270+
271+
my @rows;
272+
my %location_names;
273+
274+
foreach my $row (@$group_membership) {
275+
next if !$row->{location};
276+
push @rows, {
277+
environment => $row->{environment_label} || $row->{environment} || '',
278+
location => $row->{location},
279+
trial => $row->{trial} || '',
280+
year => $row->{year} || '',
281+
group_id => $row->{group_id} || '',
282+
group_label => $row->{group_id} || '',
283+
};
284+
$location_names{$row->{location}} = 1;
285+
}
286+
287+
foreach my $row (@$ungrouped) {
288+
next if !$row->{location};
289+
push @rows, {
290+
environment => $row->{environment_label} || $row->{environment} || '',
291+
location => $row->{location},
292+
trial => $row->{trial} || '',
293+
year => $row->{year} || '',
294+
group_id => 'Ungrouped',
295+
group_label => 'Ungrouped',
296+
};
297+
$location_names{$row->{location}} = 1;
298+
}
299+
300+
return [] if !@rows;
301+
302+
my %coordinates;
303+
my @locations = keys %location_names;
304+
my $rs = $schema->resultset("NaturalDiversity::NdGeolocation")->search({
305+
description => { -in => \@locations },
306+
});
307+
while (my $loc = $rs->next()) {
308+
$coordinates{$loc->description()} = {
309+
latitude => $loc->latitude(),
310+
longitude => $loc->longitude(),
311+
};
312+
}
313+
314+
foreach my $row (@rows) {
315+
my $coords = $coordinates{$row->{location}} || {};
316+
$row->{latitude} = $coords->{latitude};
317+
$row->{longitude} = $coords->{longitude};
318+
$row->{has_coordinates} = defined($row->{latitude}) && length($row->{latitude}) && defined($row->{longitude}) && length($row->{longitude}) ? 1 : 0;
319+
}
320+
321+
return \@rows;
322+
}
323+
324+
1;

0 commit comments

Comments
 (0)