• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Controller::Audit;

use Moose;
BEGIN { extends 'LIMS::Base'; }
with (
	'LIMS::Controller::Roles::Misc',
    'LIMS::Controller::Roles::SessionStore',
);
use namespace::clean -except => 'meta';
__PACKAGE__->meta->make_immutable(inline_constructor => 0);

use Data::Dumper;
use Statistics::Descriptive;
use LIMS::Local::ExcelHandler;

# ------------------------------------------------------------------------------
# default() should never be called direct - redirect to start page:
sub default : StartRunmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

    return $self->redirect( $self->query->url );
}

# ------------------------------------------------------------------------------
sub turnaround : Runmode { # calculates as average, 95th-percentile or lab test
    my $self = shift; $self->_debug_path($self->get_current_runmode);

    # check input params are valid, set flash message for return if not:
    my $vars = $self->_validate_input()
    || return $self->redirect( $self->query->url(path_info=>1, -query=>1) ); # warn Dumper $vars;

	my $param = $self->param('id'); # average, 95th-percentile, lab-tests

    my %methods = ( # forwards to selected method:
        percentile => 'turnaround_percentile',
        lab_test   => 'turnaround_lab_tests',
        average    => 'turnaround_average',
    ); # check it exists:
    my $func = $methods{$param} || return $self->error('no method for '.$param);

    my $first_request_date = $self->model('Request')->get_first_request_date();
    $self->tt_params( start_date => $first_request_date );

    return $self->forward($func, $vars);
}

sub turnaround_average : Runmode { # forwarded from turnaround() only
    my ($self, $vars) = @_; $self->_debug_path($self->get_current_runmode);

	my ($data, $title) = $self->model('Audit')->turnaround_times_average($vars);
	# sort data by requested field (defaults to specimen type):
    my $results = $self->_sort_turnaround_data_average($data); # AoH (sorted)
    return $self->tt_process({ data => $results, title => $title });
}

sub turnaround_percentile : Runmode { # forwarded from turnaround() only
    my ($self, $vars) = @_; $self->_debug_path($self->get_current_runmode);

	my ($data, $title)
        = $self->model('Audit')->turnaround_times_percentile($vars);
	my $results = $self->_calc_turnaround_data_percentile($data);
    return $self->tt_process({ data => $results, title => $title });
}

sub turnaround_lab_tests : Runmode { # forwarded from turnaround() only
    my ($self, $vars) = @_; $self->_debug_path($self->get_current_runmode);

    # set default duration 90d, 1yr too slow:
    if (! $vars->{constraint_type}) {
        @{$vars}{qw/constraint_type days/} = qw(days 90);
    }
	my ($data, $title)
        = $self->model('Audit')->turnaround_times_lab_tests($vars);
    return $self->tt_process({ data => $data, title => $title });
}

# ------------------------------------------------------------------------------
sub turnaround_chart : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

    my $specimen = $self->param('id');

    # check input params are valid, set flash message for return if not:
    my $vars = $self->_validate_input()
    || return $self->redirect( $self->query->url(path_info=>1, -query=>1) );
    $vars->{specimen} = $specimen; # warn Dumper $vars;

	my ($data, $title) = $self->model('Audit')->turnaround_times_chart($vars);
        # _dump_data($data); # to dump for manual calculation eg Excel

	my $stat = Statistics::Descriptive::Full->new();
	$stat->add_data(@$data);

    my %s = ( chart_title => $title );	# for session

	{ # generate frequency data & add to session for chart:
        my $unique = LIMS::Local::Utils::get_unique_elements($data); # warn Dumper $unique;
        # sort unique elements into (natural) numeric order (for use as bins):
		my @monotonic = LIMS::Local::Utils::n_sort($unique); # warn Dumper \@monotonic;
        # generate frequency distribution data using monotonic 'bins':
		my $f = $stat->frequency_distribution_ref(\@monotonic); # warn Dumper $f;
        $s{chart_data} = $f; # stash for session
	}

	# callback for .tt (scalar context = value, list context = value + index):
	my $x_percentile = sub { my $x = $stat->percentile(@_); return $x };

	{
		my %stats = (
			min		=> $stat->min(),
			max		=> $stat->max(),
			sum		=> $stat->sum(),
			mean	=> $stat->mean(),
			mode    => $stat->mode(),
			range   => $stat->sample_range(),
			total   => $stat->count(),
			median  => $stat->median(),
		    marker 	=> &$x_percentile(95), # for chart to draw 95% marker
			std_dev		=> $stat->standard_deviation(),
			variance	=> $stat->variance(),
			skewness    => $stat->skewness(),
			trimmed_mean => $stat->trimmed_mean(0,0.05), # or (0.05) for 5% either side
		); # warn Dumper \%stats;
		$s{chart_stats} = \%stats; # stash for session
		$self->tt_params( stats => \%stats );
	}

    # add all _turnaround_chart_* to session:
	$self->session->param( _turnaround_chart => \%s );

	$self->tt_params(
        start_date => $self->model('Request')->get_first_request_date(),
		specimen_type => $specimen,
		x_percentile => $x_percentile,
    );
	return $self->tt_process();
}

# ------------------------------------------------------------------------------
sub turnaround_data : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

    my $specimen = $self->param('id');

    my %vars = $self->query->Vars();
    $vars{specimen} = $specimen; # warn Dumper \%vars;

    my $xl = LIMS::Local::ExcelHandler->new;
    my @headers = qw(request_number year sample_code screened registered);
    push @headers, $self->model('Base')->does_authorisation()
        ? 'authorised' : 'reported';
	push @headers, 'delta';

    my $data = $self->model('Audit')->turnaround_times_data(\%vars); # arrayref
    my $output = $xl->generate_spreadsheet(\@headers, $data);

	$specimen =~ s/\W+/_/g; # replace non-word chars with underscore
	$specimen =~ s/_\Z//g; # remove trailing underscore

    $self->header_props(-type => 'application/excel', -expires => 'now',
		-attachment => lc $specimen . '.xls');
    return $output;
}

# ------------------------------------------------------------------------------
sub trend_analysis : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);
    my $yml = $self->get_yaml_file('trend_analysis');
    return $self->tt_process({ cfg => $yml });
}

# ------------------------------------------------------------------------------
sub nhs_number : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

     # check input params are valid, set flash message for return if not:
    my $vars = $self->_validate_input()
    || return $self->redirect( $self->query->url(path_info=>1, -query=>1) ); # warn Dumper $vars;

    my ($data, $title) = $self->model('Audit')->nhs_number_supplied($vars);

    $self->tt_params(
        data  => $data,
        title => $title,
        start_date => $self->model('Request')->get_first_request_date(),
    );
    return $self->tt_process();
}

# ------------------------------------------------------------------------------
sub revised_diagnoses : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

    # check input params are valid, set flash message for return if not:
    my $vars = $self->_validate_input()
    || return $self->redirect( $self->query->url(path_info=>1, -query=>1) ); # warn Dumper $vars;
    $vars->{sort_by} ||= 'date'; # temp. until constraints can pass env vars

    my ($data, $title) = $self->model('Audit')->revised_diagnoses($vars);

    my $total_reported = $data->{total_reported}; # count
    my $user_reported  = $data->{user_report_counts}; # if sort_by ne 'date'
    my $user_details   = $data->{user_details}; # if sort_by ne 'date'

    my $revisions = $data->{revisions}; # arrayref; maybe manipulated below, so:

    my $request_ids = $data->{request_ids}; # arrayref
    my $rev_count   = scalar @$request_ids; # revisions count

    # get specimens map:
	my $specimen_map = $self->specimen_map($request_ids);

    $self->tt_params(
        total_count   => $total_reported,
        specimen_map  => $specimen_map,
        user_details  => $user_details,
        user_counts   => $user_reported,
        rev_count     => $rev_count,
        revisions     => $revisions,
        title         => $title,
        sort_by       => $vars->{sort_by},
        start_date    => $self->model('Request')->get_first_request_date(),
    );
    return $self->tt_process();
}


# ------------------------------------------------------------------------------
sub edit_revised_diagnosis : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

	my $request_id = $self->param('id');
    my $request = $self->model('Request')->get_single_request($request_id);

	my $data = $self->model('Audit')->edit_revised_diagnosis($request_id);
	my $opts = $self->model('Base')->get_objects('DiagnosisChangeOption');

	$self->tt_params(
		data => $data,
		opts => $opts,
        request => $request,
	);
	return $self->tt_process();
}

# ------------------------------------------------------------------------------
sub do_edit_diagnosis_revision : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

	my $id = $self->param('id'); # request_diagnosis_history.id
	my $vars = $self->query->Vars();
	$vars->{id} = $id;

	my $url = $self->query->url()
		. '/audit/revised_diagnoses?sort_by='
		. $vars->{sort_by};

	unless ( $vars->{_option_id} != $vars->{option_id} ) {
		$self->flash(warning => $self->messages('request_edit')->{edit_failed});
		return $self->redirect( $url );
	}

	my $rtn = $self->model('Request')->update_request_diagnosis_history($vars);
	if ($rtn) {
		return $self->error($rtn);
	}
	else {
		$self->flash( info => $self->messages('action')->{edit_success} );
		return $self->redirect( $url );
	}
}

# ------------------------------------------------------------------------------
sub user_workload : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

    # check input params are valid, set flash message for return if not:
    my $vars = $self->_validate_input()
    || return $self->redirect( $self->query->url(path_info=>1, -query=>1) ); # warn Dumper $vars;

    my @actions = qw( screened reported authorised );

    my %args = ( action => \@actions, vars => $vars );
    my $data = $self->model('Audit')->user_workload(\%args); # warn Dumper $data;

	my $stats = $data->{stats}; # AoH
    $self->stash( duration => $data->{title}, vars => $vars ); # for .tt

    my %h1 = (); # for chart
    my %h2 = (); # for table cols
    my %h3 = (); # for individual result breakdown

    for my $entry (@$stats) { # warn Dumper $entry;
        my $request_specimen = $entry->{specimen};
        my $specimen_type = $self->_get_specimen_type($request_specimen);
           # warn Dumper [$request_specimen, $specimen_type];

        my $action = $entry->{action};
        my $user   = $entry->{username};

        $h1{$action}{$user}++;
        $h2{$action}{$user}{$specimen_type}++;
        $h3{$action}{$user}{$specimen_type}{$request_specimen}++;
    } # warn Dumper [\%h1, \%h2, \%h3];

    # freeze stats data in session for chart (to save 3 more db queries):
    $self->session_store_hashref(\%h1, '_user_workload_data');

	$self->tt_params(
		data   => \%h2,
		detail => \%h3,
		sum    => sub { LIMS::Local::Utils::sum_list(@_) }, # callback to calculate totals
	);
    $self->tt_process();
}

# ------------------------------------------------------------------------------
=begin # to get duration to lab-test status, but only recorded in history file:
sub lab_tests_to_status : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

    my $vars = $self->query->Vars(); # warn Dumper $vars;

	{ # get lab sections status options map:
		my $status_options_map = $self->all_lab_section_status_options_map();
		$self->tt_params( status_options => $status_options_map );
	}
	return $self->tt_process();
}
=cut

# ------------------------------------------------------------------------------
sub lab_tests_sign_off : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

    # check input params are valid, set flash message for return if not:
    my $vars = $self->_validate_input()
    || return $self->redirect( $self->query->url(path_info=>1, -query=>1) ); # warn Dumper $vars;

    # set default duration 90d (has no effect unless lab_section_id supplied):
    if (! $vars->{constraint_type}) {
        @{$vars}{qw/constraint_type days/} = qw(days 90);
    }

	# lab_section_id passed either as menu param, or modify constraints as id:
	my $lab_section_id = $self->param('id') || $vars->{lab_section_id};

	{ # get lab sections map - needed irrespective of lab_section_id param:
		my $lab_sections_map = $self->lab_sections_map();
		$self->tt_params( lab_sections_map => $lab_sections_map );
	}

	if ( $lab_section_id ) {
		$vars->{lab_section_id} ||= $lab_section_id; # in case it's a param('id')
		my ($data, $title) = $self->model('Audit')->lab_tests_sign_off($vars);

		my %h;
		for (@$data) {
			my $test = $_->{field_label};
			# array to retain sort order (f):
			push @{ $h{$test} }, { user => $_->{username}, f => $_->{f} };
		};

		$self->tt_params(
			data  => \%h,
			title => $title,
			section_id => $lab_section_id,
#			start_date => $self->model('Request')->get_first_request_date(), # doesn't work - WTF??
		);
	}

	return $self->tt_process();
}

# ------------------------------------------------------------------------------
# validates date contraints input, returns query params if valid, or sets flash
# message & returns 0 if not (triggers manual redirect in calling rm):
sub _validate_input {
    my $self = shift;
    my $vars = $self->query->Vars();
    # can't use dfv_error_page() to return to same rm (causes endless loop), so
    # load 'default' page then do a manual redirect in rm if params invalid:
    my $dfv = $self->check_rm( 'default', $self->validate('date_constraints') );
    if ( $dfv->has_invalid ) {
        my $invalid = join ', ', map { "$_ [$vars->{$_}]" } $dfv->invalid;
        $self->flash( error => 'invalid input: ' . $invalid );
        return 0;
    }
    return $vars; # submitted params OK
}

# ------------------------------------------------------------------------------
sub _get_specimen_type {
    my ($self, $sample_code) = @_; # warn $sample_code if $sample_code =~ '-';

    # only interested in BMAT, BMA, PB or Tissue biopsy:
    return $sample_code if grep $sample_code eq $_, qw(BMAT BMA PB); # single specimens

    return 'Tissue' if $sample_code =~ /\A[DGLRTX](A|[BS][LP]|F|U)/;

    # for multi-specimen requests:
    return 'BMAT' if $sample_code =~ /BMAT/;
    return 'BMA'  if $sample_code =~ /BMA/;
    return 'PB'   if $sample_code =~ /PB/;

    return 'Other'; # everything else, including multi-specimen request not matched
}

# ------------------------------------------------------------------------------
sub _calc_turnaround_data_percentile {
    my $self = shift;
    my $data = shift;

    my %h;
    while ( my($specimen, $d) = each %$data ) { # warn Dumper $d;
        for my $action ( qw/delta_report delta_authorise/ ) {
            next unless $d->{$action}; # next unless $specimen eq 'foo';
			# next unless $specimen eq 'Slide';
=begin # using Statistics::Descriptive
            # sort numerical vals in ascending order:
            my @vals = sort { $a <=> $b } @{ $d->{$action} }; # warn Dumper \@vals;
            # take array position of 95%:
            my $index = @vals * 0.95;  warn $index; # array pos for 95% value
            # get value for 95%:
            my $x = $vals[ int ( $index - 1 ) ]; # warn Dumper [$specimen, $x];
=cut
			my $stat = Statistics::Descriptive::Full->new();
			$stat->add_data( @{ $d->{$action} } );
			my ($x, $index) = $stat->percentile(95); # warn Dumper [$index, $x];
            $h{$specimen}{$action} = $x;
        }
        $h{$specimen}{count} = $d->{count};
    }
    return \%h;
}

# ------------------------------------------------------------------------------
sub _sort_turnaround_data_average {
    my $self = shift;
    my $data = shift;

    # default order_by is specimen type:
    my $order_by = $self->query->param('order_by') || 'type';

	my %methods = (
		type         => \&_sort_by_specimen_type,
        totals       => \&_sort_by_totals,
        delta_r2a    => \&_sort_by_delta_r2a, # report -> auth diff
        delta_auth   => \&_sort_by_delta_authorise,
        delta_report => \&_sort_by_delta_report,
	);

	# get required sort method:
	my $sort_method = $methods{$order_by};

    # get sort order for $data as a list of $data keys:
    my $sort_order = $sort_method->($data); # warn Dumper $sort_order;

    # add $data key (specimen type) to its own hashref val:
    $data->{$_}->{type} = $_ for keys %$data;

    # create array from $data in requested sort order:
    my @sorted_data = map $data->{$_}, @$sort_order; # add $data vals in sort order
    return \@sorted_data;
}

# ------------------------------------------------------------------------------
sub _sort_by_specimen_type {
    my $data = shift; # warn Dumper $data;
    my @sort_order = sort { $a cmp $b } keys %$data;
	return \@sort_order;
}

# ------------------------------------------------------------------------------
sub _sort_by_totals {
    my $data = shift; # warn Dumper $data; # hashref

    my @sort_order = sort {
		$data->{$a}->{count} <=> $data->{$b}->{count}
        || # 2nd sort by keys (ie specimen type) in case similar counts:
        $a cmp $b
	} keys %$data; # warn Dumper \@sort_order;

	return \@sort_order;
}

# ------------------------------------------------------------------------------
sub _sort_by_delta_report {
    my $data = shift; # warn Dumper $data;

    my @sort_order = sort {
		$data->{$a}->{delta_report} / $data->{$a}->{count}
          <=>
        $data->{$b}->{delta_report} / $data->{$b}->{count}
        || $a cmp $b # 2nd sort by keys (ie specimen type) in case similar counts
	} keys %$data;

	return \@sort_order;
}

# ------------------------------------------------------------------------------
sub _sort_by_delta_authorise {
    my $data = shift; # warn Dumper $data;

    my @sort_order = sort {
		$data->{$a}->{delta_authorise} / $data->{$a}->{count}
          <=>
        $data->{$b}->{delta_authorise} / $data->{$b}->{count}
        || $a cmp $b # 2nd sort by keys (ie specimen type) in case similar counts
	} keys %$data;

	return \@sort_order;
}

# ------------------------------------------------------------------------------
sub _sort_by_delta_r2a { # diff. between delta_report & delta_authorisation
    my $data = shift; # warn Dumper $data;

    my @sort_order = sort {
		(
            $data->{$a}->{delta_authorise} / $data->{$a}->{count} -
            $data->{$a}->{delta_report}    / $data->{$a}->{count}
        )
          <=>
		(
            $data->{$b}->{delta_authorise} / $data->{$b}->{count} -
            $data->{$b}->{delta_report}    / $data->{$b}->{count}
        )
        || $a cmp $b # 2nd sort by keys (ie specimen type) in case similar counts
	} keys %$data;

	return \@sort_order;
}

sub _dump_data {
	my $data = shift;
	open my $fh, '>', './data.txt';
	print $fh $_ . ",\n" for @$data;
}

1;