roc_ui.pl

A Perl module implementing receiver-operator-characteristic (ROC) curves with nonparametric confid

#!perl  -w
#LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
#
#    Graphical User Interface for drawing and printing
#          
#    ROC curves with nonparametric confidence bounds
#
#    
#    
#
#     copyright 1998-2007 by Hans A. Kestler
#
#
#    Locations of Perl and modules have to be adapted to local configurations.
#
#LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL

# change paths if needed (probably)
#use lib '/opt/perl5/lib/site_perl/5.005/PA-RISC2.0/Tk'; 
#use lib '/home/kestler/PL/ROC.core/';
#use lib '/Applications/perl2exe/perl5/lib/site_perl/5.8.8/Tk';

#LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
use Statistics::ROC;

use Carp;
use strict;
use Cwd;
use Cwd 'chdir';
use File::Basename;

use Tk;
require Tk::Dialog;

#use Tk::DialogBox;
#use Tk::DummyEncode;
#use Tk::Canvas;
#use utf8;
#use Tk::Menubutton;
#use Tk::Scale;
#use Tk::Optionmenu;
#use Tk::Bitmap;
#use Tk::FBox;
#LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL

##################### global variables ################
use vars qw/$VERSION $undef $loadfirst $fname $DIALOG_ABOUT $DIALOG_USAGE 
                                             $DIALOG_LOAD_ERROR $WAIT_BOX/;


$,=" ";
$VERSION='0.04';
$undef=0;
$loadfirst=0;
$fname=""; 


###########################################################################
###########################################################################
######
###### Graphical User Interface
######
###########################################################################
###########################################################################

# predeclare subroutines
sub make_menubutton;
sub roc_save;
sub fileSelector;
sub draw_roc;
sub initialize_messages;


sub make_menubutton { 
    # This function is courtesy of Steve Lidie, The Perl Journal, vol 1, no 1,
    # 1996.
    #	
    # Make a Menubutton widget; note that the Menu is automatically created.  
    # If the label is '', make a separator.

    my($mbf, $mb_label, $mb_label_underline, $pack, $mb_list_ref) = @_;

    my $mb = $mbf->Menubutton(
			       -text      => $mb_label, 
			       -underline => $mb_label_underline,
			      );
    my $mb_list;
    foreach $mb_list (@{$mb_list_ref}) {
	$mb_list->[0] eq '' ? $mb->separator :
	    $mb->command(
			 -label     => $mb_list->[0], 
			 -command   => $mb_list->[1], 
			 -underline => $mb_list->[2],
			 );
    }
    $mb->pack(-side => $pack);
    return $mb;
} # end make_menubutton




sub roc_save{
    # Saves or prints the ROC curve (canvas widget, drawing area)
    #
    # If the value of the hash is a string with "lpr" at the beginning
    # the drawing area will be piped to the postscript printer otherwise 
    # it will be saved as a postscript file.
    # Arguments: * handle to the canvas widget
    #            * value of entry field (string)
    
    my($w, $pinfo) = @_;    
    my($a,$psfname);
   
    $a = $w->postscript;
            
    if($pinfo->{'prcmd'}=~/^lpr/){
       open(LPR, "| $pinfo->{'prcmd'}");
       #print "yes lpr \n";
    }
    else{
       #print "no lpr file\n";
       #print dirname($fname)."/".$pinfo->{'prcmd'},"\n";
       #open(LPR, ">$pinfo->{'prcmd'}");
       $psfname = dirname($fname)."/".$pinfo->{'prcmd'};
       open(LPR, ">$psfname");
    }
    print LPR $a;close(LPR);
} # end roc_save


sub fileSelector{
    # File selection widget.
    # 
    # Selects and loads a datafile and draws the ROC curve with
    # default values. Makes checks on data.
    # Lines beginning with $ and # are treated as commentaries.
    # Uses the Tk::getOpenFile widget for file selection.
    #
    # Arguments: * handle of the main window
    #            * handle of the canvas widget
    #            * (0,0)- and (1,1)-points in pixels
    #              of the drawing area (this is the complete drawing area).
    #              It is assumed that y-coordinates increase from top
    #              to bottom of the widget, the x-coord. increase as expected
    #              from left to right.
    #            * the model type, this is a reference to string
    #            * the 2-sided confidence interval in %
    #            * the reference to the data (list-of-list)

    my $but=shift;
    my($MW,$c,$xzero,$yzero,$xone,$yone,$model_type_ref,
                                          $conf_ref,$var_grp_ref)   = @$but;  
    my($Horiz) = 1;
    # my $fname; 
    my $dir=cwd();
    my @line=();
    
    @$$var_grp_ref=();  # reinitialize data array
        

 
    
    $fname = $MW->getOpenFile(-title =>'Select a datafile!', -initialdir =>'.'); # $fname needs to be global for draw_roc
    
    
    
    return if !defined($fname); # check if filename is valid

    $main::name=fileparse($fname);
    $MW->title("ROC with confidence: $main::name");
   


    # open file and read in data
    open(DATA, "$fname");
    LINE: 
    while(<DATA>){ 
          next LINE if /^#/ || /^$/;
          @line=split;
          if(($line[1] != 1 && $line[1] != 0) ||
              $line[0] !~ /^(\+|-)?(\d+(\.\d*)?|\.\d+)(E|e)?(\+|-)?\d*$/)
          {                 
             $DIALOG_LOAD_ERROR->Show; return;
          }  
          push @$$var_grp_ref, [ @line ];
    }
    
    # check for not existing data
    if(!scalar(@$$var_grp_ref)){$DIALOG_LOAD_ERROR->Show; return;}
    
    # set loadfirst flag to indicate that data is loaded
    $loadfirst=1;
        
    draw_roc([$c,$xzero,$yzero,$xone,$yone,$model_type_ref,$conf_ref,$var_grp_ref]);
    
} # end of fileSelector


sub draw_roc{
  # Draws the receiver-operator characteristic curve with confidence bounds.
  #
  # Arguments: * handle of the canvas widget
  #            * (0,0)- and (1,1)-points in pixels
  #              of the drawing area (this is the complete drawing area).
  #              It is assumed that y-coordinates increase from top
  #              to bottom of the widget, the x-coord. increases as expected
  #              from left to right.
  #            * the model type, this is a reference to string
  #            * the 2-sided confidence interval in %
  #            * the reference to the data (list-of-list)
  
  my $but=shift;
  my ($c,$xzero,$yzero,$xone,$yone,$model_type,$conf,$var_grp)=@$but;
  my $m_type;
  
  #print $$model_type,"\n";print $$conf,"\n";
  #print ref($$model_type),"\n";print ref($$conf),"\n";
  

  # check for not existing data
  if(!$loadfirst){$DIALOG_LOAD_ERROR->Show; return;}
  
  ($main::state_b,$main::state_o,$main::state_p,$main::state_r,$main::state_v)=
                                                            (1,1,1,1,1); # reset checkbuttons
  

  
  if($$model_type eq 'grp0 > grp1'){$m_type='decrease'}
  elsif($$model_type eq 'grp0 < grp1'){$m_type='increase'}
  else{ croak "Wrong model type in userinterface\n";}
  
  
  my @ROC=roc($m_type,$$conf/100,@$$var_grp);   
  my $label;
  
  for(my $j=0,my $width;$j<3;$j++)
    {
      if($j==1){$width=2; $label='plot';}else{$width=1;$label='bounds';} # set ROC line width to 2
      for(my $i=0;$i<@{$ROC[0]}-1;$i++) # step thru (x,y)-pairs
	{
          $c->create('line',
		     ($xone-$xzero)*$ROC[$j][$i][0]+$xzero,
		     ($yone-$yzero)*$ROC[$j][$i][1]+$yzero,
		     ($xone-$xzero)*$ROC[$j][$i+1][0]+$xzero,
		     ($yone-$yzero)*$ROC[$j][$i+1][1]+$yzero, 
		     -fill=>'red',  -tags=>[$label],    
		     -width=>$width);
	} 
    }
  

  my ($i,$tmp);

   
  
  # calculate optimal cutoff value of empirical ROC curve  
  my($rp,$fp,$rn,$fn)=(0,0,0,0);
  my($acc,$sensi,$speci,$ppv,$npv);
  my @ss2=();
  my $g;
  my $gmax;
  my ($text1,$text2);
   
  for( my $j=0;$j<@$$var_grp;$j++)    
    {	
      $g = $$$var_grp[$j][0]; 	
      #print $g, "\n";
      ($rp,$fp,$rn,$fn)=(0,0,0,0);  
      for($i=0;$i<@$$var_grp;$i++)
	{ 
	  if($m_type eq 'increase')
	    {
	      if($$$var_grp[$i][0] > $g)
		{
		  if($$$var_grp[$i][1] == 1){$rp++;}
		  else {$fp++;}
		}
	      else
		{
		  if($$$var_grp[$i][1] == 0){$rn++;}
		  else {$fn++;}
		}
	    }
	  else			# modeltype decrease
	    {
	      if($$$var_grp[$i][0] < $g)
		{
		  if($$$var_grp[$i][1] == 1){$rp++;}
		  else {$fp++;}
		}
	      else
		{
		  if($$$var_grp[$i][1] == 0){$rn++;}
		  else {$fn++;}
		}
	    }
	}
      #print "$rp $rn $fn $fp \n";
      # acc sensi speci ppv npv
      if(!eval{$acc   = ($rn + $rp) / ($rn + $rp + $fn + $fp);}) {$acc=$undef;}
      if(!eval{$sensi = $rp / ($fn + $rp);}) {$sensi=$undef;}
      if(!eval{$speci = $rn / ($fp + $rn);}) {$speci=$undef;}
      if(!eval{$ppv   = $rp / ($fp + $rp);}) {$ppv=$undef;}
      if(!eval{$npv   = $rn / ($fn + $rn);}) {$npv=$undef;}
      #print "Threshold: $g \n";
      #print "$acc, $sensi, $speci, $ppv, $npv \n";
      #print "---------------\n";
      push @ss2, [$acc, $sensi, $speci, $ppv, $npv];  
    }
 
  for($i=0,$tmp=$ss2[0][1]+$ss2[0][2],$gmax=$tmp;$i<@ss2;$i++)
    {       
      if($ss2[$i][1]+$ss2[$i][2]>$tmp) {$tmp=$ss2[$i][1]+$ss2[$i][2]; $gmax=$i;}      
    } 
  
  $c->createText($xzero+300, $yone-20,
		 -text=>"Threshold: $$$var_grp[$gmax][0]",
		 -tags=>['values']);
  
 
  # rounding routine because 0.8125 rounds falsely with %.3 to 0.812
  sub round {$_[0] >0 ? int $_[0]+0.5 : int $_[0]-0.5}
  $text1= sprintf "ACC SENSI SPECI PPV NPV\n%.3f %.3f %.3f %.3f %.3f", 
                                         map {round(int($_ *10000)/10)/1000} @{$ss2[$gmax]};  
  $c->createText($xzero+100, $yone-20,
		 -text=>$text1,
		 -tags=>['values']);

  $c->createLine(($xone-$xzero)*(1-$ss2[$gmax][2])+$xzero, 
	     $yzero,
	     ($xone-$xzero)*(1-$ss2[$gmax][2])+$xzero,
	     ($yone-$yzero)*$ss2[$gmax][1]+$yzero, 
	     -fill=>'blue',  -tags=>['opt'],    
	     -width=>1);

  $c->createLine($xzero, 
	     ($yone-$yzero)*$ss2[$gmax][1]+$yzero,
             ($xone-$xzero)*(1-$ss2[$gmax][2])+$xzero,
	     ($yone-$yzero)*$ss2[$gmax][1]+$yzero, 
	     -fill=>'blue',  -tags=>['opt'],    
	     -width=>1);

  $c->createOval(($xone-$xzero)*(1-$ss2[$gmax][2])+$xzero-6,           
	     ($yone-$yzero)*$ss2[$gmax][1]+$yzero-6,
	     ($xone-$xzero)*(1-$ss2[$gmax][2])+$xzero+6,           
	     ($yone-$yzero)*$ss2[$gmax][1]+$yzero+6,
	     -width=>1,-fill=>'blue',-tags=>['opt']);
 
  $text2= sprintf "%1.3f\n%1.3f", 1-$ss2[$gmax][2], $ss2[$gmax][1];
  $c->createText(($xone-$xzero)*(1-$ss2[$gmax][2])+$xzero,           
		 ($yone-$yzero)*$ss2[$gmax][1]+$yzero-30,
		 -text=>$text2,
		 -tags=>['opt','values']);
  
  
    
  
  my @s=sort{(1-$ss2[$a][2]) <=> (1-$ss2[$b][2]) || $ss2[$a][1] <=> $ss2[$b][1]} 0..$#ss2;
  #print " $#ss2  $#s \n";
  @ss2=@ss2[@s];
  #for($i=0;$i<@ss2;$i++){print 1-$ss2[$i][2], $ss2[$i][1] ,"\n";}
  
  for($i=0;$i<$#ss2;$i++)	  # step thru (x,y)-pairs
    {
      $c->createLine(
		     ($xone-$xzero)*(1-$ss2[$i][2])+$xzero,
		     ($yone-$yzero)*$ss2[$i][1]+$yzero,
		     ($xone-$xzero)*(1-$ss2[$i+1][2])+$xzero,
		     ($yone-$yzero)*$ss2[$i+1][1]+$yzero, 
		     -fill=>'green4',  -tags=>['realroc'],    
		     -width=>2);
    } 
   
  
  # save ROC curves to file
  if($main::state_s)
    {
      #$c->messageBox(-icon => 'error', -message => 'Cannot create roc-file.');
      unless (open CURVES, ">$fname.txt") {die "Cannot create roc-file: $!";}
      print CURVES "$fname.txt\n";  # print filename