package LIMS::Local::GenomicsValidation;
use Moo;
use Local::Utils;
use Clone qw(clone);
use Data::Printer alias => 'p';
use XML::SAX::ParserFactory;
use XML::Validator::Schema;
has xsd_src => ( is => 'ro', required => 1 );
has dbix => ( is => 'ro', required => 1 );
has cfg => ( is => 'ro', required => 1 );
has rare_disease_base => ( is => 'lazy' );
has family_id_prefix => ( is => 'lazy' );
has cancer_increment => ( is => 'lazy' );
has lab_tests_map => ( is => 'lazy' );
sub _build_cancer_increment { shift->cfg->{genomics}->{uat}->{cancer_incr} }
sub _build_rare_disease_base { shift->cfg->{genomics}->{uat}->{rare_disease} }
sub _build_family_id_prefix {
my $self = shift;
# family_id_prefix = 1st 3 digits of rare_disease participant id base:
my ($family_id_prefix) = $self->rare_disease_base =~ /^(\d{3})/; # p $family_id_prefix;
return $family_id_prefix;
}
sub _build_lab_tests_map { # warn '=' x 30;
my $self = shift;
my $sql = q!SELECT lt.test_name, lt.field_label, ls.section_name
FROM lab_tests lt JOIN lab_sections ls on lt.lab_section_id = ls.id!;
$self->dbix->query($sql)->hash_map('test_name');
}
no autovivification;
sub validate_params {
my ($self, $data) = @_; # p $data; # hashref
my %errors;
my $c = clone $data; # to prevent auto-vivification
# family ID (is RD-specific) is 9 digits & begins with 1st 3 digits of
# rare_disease participant id base (122xxxxxx):
if ( my $family_id = $c->{Approach}->{family_id} ) { # warn $family_id;
=begin # family_id should be participant_id + max 9 individuals, but doesn't
# work in practice as family_id just has to match a participant_id which
# could be any number of requests different
my $participant_id = $c->{Demographics}->{participant_id};
unless ( $participant_id - $family_id ~~ [0..9] ) {
# p [ $participant_id, $family_id ];
$h{family_id} = $family_id;
}
=cut
my $err_msg;
# family_id_prefix is 1st 3 digits of rare_disease participant id base:
my $family_id_prefix = $self->family_id_prefix; # p $family_id_prefix;
# must be rare-disease type:
my $arm = $c->{Demographics}->{arm}; # p $arm;
if ( ! $arm || lc $arm ne 'rare disease' ) {
$err_msg = 'family ID only valid for rare disease category';
}
# must begin with rare-disease prefix (122) + 6 digits:
elsif ( $family_id !~ /^$family_id_prefix\d{6}$/ ) {
$err_msg = 'invalid format (require 122xxxxxx)';
}
else {
# check family_id belongs to an existing participant_id (unit_number):
my $pid_match_ok = $self->dbix->select('patient_case', 1,
{ unit_number => $family_id })->value; # p $pid_match_ok; p $family_id;
unless ( $pid_match_ok ) {
$err_msg = 'no matching proband';
}
}
if ($err_msg) {
my %h = ( val => $family_id, err => $err_msg );
$errors{family_id} = \%h;
}
}
# participant ID is 9 digits and matches allocated RD or Cancer block:
if ( my $participant_id = $c->{Demographics}->{participant_id} ) { # p $participant_id;
my $request_id = $c->{Demographics}->{request_id};
my $expected = $self->rare_disease_base + $request_id;
if ( my $arm = $c->{Demographics}->{arm} ) {
$expected += $self->cancer_increment if lc $arm eq 'cancer';
} # p $expected;
else { # not screened:
$expected = 0; # ensures failure even if length = 9
}
my $match_ok = _matches($participant_id, $expected);
unless ( $match_ok && length $participant_id == 9 ) {
my $err = $expected # non-value means request unscreened
? $match_ok # must be invalid length if match_ok
? 'does not match expected length (9 characters)'
: 'does not match expected numerical range for disease type'
: 'unexpected value for unscreened record';
my %h = (
val => $participant_id,
err => $err,
);
$errors{participant_id} = \%h;
# need to add participant_id (ie unit number) manually to
# $self->lab_test_map for error decode for notification:
$self->lab_tests_map->{participant_id} ||= { # unless already added
section_name => 'Patient demographics', # not strictly a lab-section
field_label => 'Unit number',
}; # p $map;
}
}
# nhs number:
unless ( $c->{Demographics}->{nhs_number} ) {
$errors{nhs_number} = undef;
}
=begin # validated in validate_xml_against_xsd() using XML libs now
# DNA/volume_stored is xs:small (integer):
if ( my $val = $data->{DNA}->{volume_stored} ) {
unless ($val =~ /^\d+$/) { # warn 'here';
$data->{DNA}->{volume_stored} = int($val);
}
}
# DNA/edta1_fluidx_vol is xs:small (integer):
if ( my $val = $data->{DNA}->{edta1_fluidx_vol} ) {
unless ($val =~ /^\d+$/) { # warn 'here';
$data->{DNA}->{edta1_fluidx_vol} = int($val);
}
}
=cut
{ # sample ID's (9-digits, decimal, 1/2-digits:
my %data = ();
{ # Specimens - blood section:
$data{$_} = $c->{SpecimensBlood}->{$_} for
qw( paxgene_rna edta1 edta2 sst pst );
}
{ # Specimens - saliva section:
$data{$_} = $c->{SpecimensSaliva}->{$_} for
qw( oragene_tube_1 oragene_tube_2 );
}
# tumour specimen ID:
$data{sample_id} = $c->{SpecimensTumour}->{sample_id}; # p \%data;
# bone marrow specimen ID:
$data{bm_sample_id} = $c->{SpecimensBoneMarrow}->{bm_sample_id};
while ( my ($test, $val) = each %data ) { # warn $test; # warn $val;
next unless $val && $val !~ /^\d{9}\.\d{1,2}$/;
$errors{$test} = { val => $val, err => undef }; # use default err msg
}
}
# p \%errors;
my $lab_tests_map = $self->lab_tests_map; # p $lab_tests_map;
my $default_error = 'does not match required definition';
my @errs = map { # same format as genomics_xml.pl notify_admin msg:
( $errors{$_}
? ( sprintf qq!Illegal value '%s' !, $errors{$_}{val} )
: 'Illegal NULL value ' )
. sprintf q!for '%s' in '%s' section, %s.!,
$lab_tests_map->{$_}{field_label},
$lab_tests_map->{$_}{section_name},
$errors{$_}{err} || $default_error;
} keys %errors;
return @errs ? \@errs : 0; # don't return empty arrayref (evals 'true' for caller)
}
#-------------------------------------------------------------------------------
sub validate_xml_against_xsd {
my ($self, $xml) = @_; # warn $xml;
my $xsd_src = $self->xsd_src;
# switch debug on to show data structure:
my $validator = XML::Validator::Schema->new(file => $xsd_src, debug => 0); # p $validator;
my $parser = XML::SAX::ParserFactory->parser(Handler => $validator);
eval { $parser->parse_string($xml); };
return $@;
}
#-------------------------------------------------------------------------------
sub reformat_error {
my ($self, $error) = @_;
my ($lab_test) = $error =~ m!element <(.*)>!; # p $lab_test;
my $lab_tests_map = $self->lab_tests_map; # p $lab_tests_map;
if ( my $ref = $lab_tests_map->{$lab_test} ) { # get field label & section
my $section = $ref->{section_name};
my $label = $ref->{field_label};
$error =~ s/in element <$lab_test>/for '$label' in '$section' section/; # p $error;
}
return $error;
}
sub _matches { Local::Utils::matches(@_) }
1;
