use Modern::Perl; use lib ( '/home/raj/perl-lib', '/home/raj/perl-lib/ChartDirector/lib', ); use Data::Printer ( alias => 'p', use_prototypes => 0 ); use SQL::Abstract::More; use FindBin qw($Bin); use Local::Utils; use Local::DB; use DateTime; use perlchartdir; use autodie; #=============================================================================== my $interval = 3; # months #=============================================================================== $Local::QueryLogger::NO_QUERY_LOGS = 1; # don't need queries in logs dir my $dbix = Local::DB->dbix({ dbname => 'hilis4' }); my $sqla = SQL::Abstract::More->new; my $today = Local::Utils::today(); my @tbl_rels = ( 'requests|r' , 'r.id = tr.request_id' , 'request_lab_test_results|tr' , 'tr.lab_test_id = lt.id' , 'lab_tests|lt' , 'ls.id = lt.lab_section_id' , 'lab_sections|ls' , 'r.id = rrd.request_id' , 'request_report_detail|rrd' , 'rrd.diagnosis_id = d.id' , 'diagnoses|d' ); my %tests = ( myc_dlbcl => { # myc in DLBCL restriction => { 'd.icdo3' => '9680/3', 'lt.test_name' => 'cmyc', 'ls.section_name' => 'FISH', }, title => { chart => 'MYC/DLBCL', yAxis1 => 'MYC rearrangement frequency', yAxis2 => 'total MYC requests', imgName => 'myc_dlbcl', }, gene_status => 'rearranged', }, tp53_cll => { restriction => { 'd.icdo3' => '9823/3', 'd.name' => { rlike => 'cll', not_rlike => 'B-cell lymphocytosis' }, # check which cll's required 'lt.test_name' => 'p53', 'ls.section_name' => 'FISH', }, # icdo3 = '9823/3' and name rlike 'cll' and name not rlike 'Monoclonal B-cell lymphocytosis' title => { chart => 'TP53/CLL', yAxis1 => 'TP53 deletion frequency', yAxis2 => 'total TP53 requests', imgName => 'p53_cll', }, gene_status => 'deletion', }, fgfr3_igh_myeloma => { restriction => { 'd.icdo3' => '9732/3', 'lt.test_name' => 'fgfr3_igh', 'ls.section_name' => 'FISH', }, title => { chart => 'FGFR3-IGH/myeloma', yAxis1 => 'FGFR3-IGH translocation frequency', yAxis2 => 'total FGFR3-IGH requests', imgName => 'fgfr3_igh_myeloma', }, gene_status => 'translocation', }, ); while ( my ($test, $data) = each %tests ) { my %h; # hashref of restrictions for where clause (eg icdo3 => '9830/3): my $restriction = $data->{restriction}; # test result for monitoring (eg rearranged, deleted, etc): my $gene_status = $data->{gene_status}; for my $i (0 .. 24) { # intervals next if $i % $interval; # p $i; # every 3 months my ($sql, @bind) = _generate_query($restriction, $i); my $results = $dbix->query($sql, @bind)->map; # p $results; my $result = $results->{$gene_status}; # p $result; my $total = Local::Utils::math_sum(values %$results); # p $total; my $value = $result / $total; # p [$i, $value]; push @{ $h{interval} }, $i; push @{ $h{value} }, $value; push @{ $h{totals} }, $total; } # p \%h; my $chart = make_chart(\%h, $data->{title}); } sub make_chart { my ($data, $title) = @_; # chart data (reverse order for all values): my @freqs = reverse @{ $data->{value} }; my @totals = reverse @{ $data->{totals} }; # make labels negative (needs escaped '-'), exept zero (0, -3, -6, etc): my @labels = map { $_ ? '\-'.$_ : $_ } reverse @{ $data->{interval} }; # p \@labels; # Create a XYChart object of size 300 x 180 pixels my $c = new XYChart(650, 350); # Set the plot area at (50, 20) and of size 200 x 130 pixels $c->setPlotArea(60, 40, 520, 250); # Add a title to the chart using 8pt Arial Bold font $c->addTitle($title->{chart}, "arialbd.ttf", 10); my $totals_color = 0x008000; # green my $freqs_color = 0xc00000; # red my $area_color = 0x8033ff33; # lime # Set the labels on the x axis. $c->xAxis()->setLabels(\@labels); $c->xAxis()->setTitle("$interval-month intervals"); # Add a title to the primary (left) y axis $c->yAxis()->setTitle($title->{yAxis1}); # Set the axis, label and title colors for the primary y axis: $c->yAxis()->setColors($freqs_color, $freqs_color, $freqs_color); # primary y axis - frequency data: my $layer1 = $c->addLineLayer(); $layer1->addDataSet(\@freqs, $freqs_color)->setDataSymbol( $perlchartdir::CircleSymbol, 7); $layer1->setLineWidth(1); # Add a title to the secondary (right) y axis $c->yAxis2()->setTitle($title->{yAxis2}); # set the axis, label and title colors for the secondary y axis: $c->yAxis2()->setColors($totals_color, $totals_color, $totals_color); $c->yAxis2()->setLinearScale(0, $perlchartdir::NoValue); # totals data for secondary y axis: # my $layer2 = $c->addLineLayer(); # using coloured area: # $layer2->addDataSet($totals, 0x00c000)->setDataSymbol( # $perlchartdir::DiamondSymbol, 7); # $layer2->setLineWidth(2); my $layer2 = $c->addAreaLayer(\@totals, $area_color); # $c->yZoneColor(60, 0x8033ff33, 0x80ff3333)); $layer2->setLineWidth(0); # no line on top of area $layer2->setUseYAxis2(); # Output the chart my $filename = sprintf '%s/%s.png', $Bin, $title->{imgName}; $c->makeChart($filename); } sub _generate_query { my ($restriction, $n) = @_; # warn $t0; my $t1 = $today->clone->subtract(months => $n + 3)->ymd; my $t2 = $today->clone->subtract(months => $n)->ymd; $restriction->{'date(tr.time)'} = { -between => [ $t1, $t2 ] }; my ($sql, @bind) = $sqla->select( -columns => [ 'tr.result', 'count(*)' ], -from => [ -join => @tbl_rels ], -where => $restriction, -group_by => 'tr.result', ); # p $sql; p \@bind; return ($sql, @bind); }