bin/check_termination

   1 #!/usr/local/bin/perl
   2
   3 use FindBin qw($Bin);
   4 use lib "$Bin/../lib";
   5
   6 # Don't edit the line below, it must look exactly like this.
   7 # Everything above this line will be replaced #
   8
   9 use PsN;
  10 use model;
  11 use output;
  12 use tool::modelfit;
  13 use Data::Dumper;
  14 use debug;
  15 use strict;
  16
  17 $Data::Dumper::Maxdepth=$ARGV[1];
  18
  19 # ------------------------------------------------------------------#
  20
  21 # Model evaluation. Part one. Version 0.1
  22
  23 # This script checks a nonmem output file. The parts
  24 # concerning parts of the covariance step obviously needs the $COV
  25 # record. In addition, the condition number test needs the PRINT=E
  26 # option of the $COV record. The limits for the relative tests may be
  27 # changed below:
  28
  29 my $correlation_limit = 0.9;      # All correlations above this number
  30                                   # will be listed.
  31 my $condition_number_limit = 1000;    # An error will be rised if the
  32                                       # condition number is greater
  33                                       # than this number.
  34 my $near_bound_sign_digits = 2;     # If a parameter estimate is equal
  35                                     # to a bound with this many
  36                                     # significant digits, a warning
  37                                     # will be printed.
  38 my $near_zero_boundary_limit = 0.001;  # When the bound is zero, the
  39                                        # check above is not valid. Use
  40                                        # this limit instead.
  41 my $sign_digits_off_diagonals = 2;    # The off-diagonal elements are
  42                                       # checked against +-1 with this
  43                                       # many significant digits.
  44 my $large_theta_cv_limit = 0.30;    # Coefficients of variation larger
  45                                     # than these numbers will produce
  46                                     # warnings.
  47 my $large_omega_cv_limit = 0.50;
  48 my $large_sigma_cv_limit = 0.30;
  49
  50 $| = 1; # Make sure autoflush is on
  51 #debug -> level(2);
  52 #debug -> subroutine('large_standard_errors');
  53
  54 sub confirm {
  55   my $default = shift;
  56   die "A default value of 0 or 1 for the answer must be defined\n"
  57     if ( not defined $default );
  58   my $input = <STDIN>;
  59   if ( $input =~ /^\s*[yY]\s*$/ ) {
  60     return 1;
  61   } elsif ( $input =~ /^\s*[nN]\s*$/ ) {
  62     return 0;
  63   } else {
  64     return $default;
  65   }
  66 }
  67
  68 sub acknowledge {
  69   my $name    = shift;
  70   my $outcome = shift;
  71   my $file    = shift;
  72   my $l = (7 - length( $outcome ))/2;
  73   my $c_num = '00';
  74   $c_num    = '07' if ( $outcome eq 'OK' );
  75   $c_num    = '13' if ( $outcome eq 'WARNING' );
  76   $c_num    = '05' if ( $outcome eq 'ERROR' );
  77   # my $text = sprintf( "%-66s%2s%7s%-5s\n\n", $name, '[ ', $outcome. ' ' x $l, ' ]' );
  78
  79   my $text = sprintf( "%-66s%2s%7s%-5s", $name, '[ ', $outcome. ' ' x $l, ' ]' );
  80
  81 #  cprintf( "%-66s%2s\x03$c_num%7s\x030%-5s", $name, '[ ', $outcome. ' ' x $l, ' ]' );
  82 #  my $text = cprintf( "%-66s%2s\x03$c_num%7s\x030%-5s", $name, '[ ', $outcome. ' ' x $l, ' ]' );
  83   print $text, "\n\n";
  84   print $file $text if defined $file;
  85 }
  86
  87
  88 #my $orig_model = model -> new( filename => $ARGV[0] );
  89 #my $output     = $orig_model -> outputs -> [0];
  90 my $output = output -> new( filename => $ARGV[0] );
  91
  92 open( my $log, ">test.log" );
  93
  94 my $eigen_run     = 1;
  95 my $corr_matr_run = 1;
  96
  97 for ( my $i = 0; $i < scalar @{$output -> problems}; $i++ ) {
  98   print "PROBLEM ",$i+1,"\n" if scalar @{$output -> problems} > 1;
  99   for ( my $j = 0; $j < scalar @{$output -> problems -> [$i] -> subproblems}; $j++ ) {
 100     print "SUBPROBLEM ",$i+1,"\n" if scalar @{$output -> problems -> [$i] -> subproblems} > 1;
 101
 102     if ( $output -> minimization_successful -> [$i][$j] eq '1' ) {
 103       acknowledge( 'Successful minimization', 'OK', $log );
 104     } else {
 105       acknowledge( 'Termination problems', 'ERROR', $log );
 106     }
 107     if ( $output -> rounding_errors -> [$i][$j] eq '0' ) {
 108       acknowledge( 'No rounding errors', 'OK', $log );
 109     } else {
 110       acknowledge( 'Rounding errors', 'ERROR', $log );
 111     }
 112
 113     if ( $output -> zero_gradients -> [$i][$j] eq '0' ) {
 114       acknowledge( 'No zero gradients', 'OK', $log );
 115     } else {
 116       acknowledge( 'Zero gradients found '.$output -> zero_gradients -> [$i][$j].' times', 'ERROR', $log );
 117     }
 118
 119     if ( $output -> final_zero_gradients -> [$i][$j] eq '0' ) {
 120       acknowledge( 'No final zero gradients', 'OK', $log );
 121     } else {
 122       acknowledge( 'Final zero gradients', 'ERROR', $log );
 123     }
 124
 125     if ( $output -> hessian_reset -> [$i][$j] eq '0' ) {
 126       acknowledge( 'Hessian not reset', 'OK', $log );
 127     } else {
 128       acknowledge( 'Hessian reset '.$output -> hessian_reset -> [$i][$j].' times', 'WARNING', $log );
 129     }
 130
 131     my ( $n_b, $f_b, $f_e ) =
 132       $output -> near_bounds( zero_limit         => $near_zero_boundary_limit,
 133                               significant_digits => $near_bound_sign_digits,
 134                               off_diagonal_sign_digits => $sign_digits_off_diagonals );
 135     if ( defined $n_b -> [$i] and
 136          defined $n_b -> [$i][$j] ) {
 137       my @near_bounds = @{$n_b -> [$i][$j]};
 138       my @found_bounds = @{$f_b -> [$i][$j]};
 139       my @found_estimates = @{$f_e -> [$i][$j]};
 140       if ( $#near_bounds < 0 ) {
 141         acknowledge( 'No parameter near boundary', 'OK', $log );
 142       } else {
 143         acknowledge( 'Parameter(s) near boundary', 'WARNING', $log );
 144         for ( my $i = 0; $i <= $#near_bounds; $i++ ) {
 145           printf( "\t%-20s%10g   %10g\n", $near_bounds[$i],
 146                   $found_estimates[$i], $found_bounds[$i] );
 147           print $log sprintf( "\t%-20s%10g   %10g\n", $near_bounds[$i],
 148                               $found_estimates[$i], $found_bounds[$i] );
 149           print "\n" if ( $i == $#near_bounds );
 150           print $log "\n" if ( $i == $#near_bounds );
 151         }
 152       }
 153     }
 154
 155     if ( $output -> covariance_step_run -> [$i] ) {
 156       if (  $output -> covariance_step_successful -> [$i][$j] eq '0' ) {
 157         acknowledge( 'Covariance step', 'ERROR', $log );
 158       } else {
 159         if ( $output -> covariance_step_successful -> [$i][$j] eq '1' ) {
 160           acknowledge( 'Covariance step ', 'OK', $log );
 161         }else {
 162           acknowledge( 'Covariance step', 'WARNING', $log );
 163         }
 164
 165         my ( $l_se, $f_cv ) =
 166           $output -> large_standard_errors( theta_cv_limit => $large_theta_cv_limit,
 167                                             omega_cv_limit => $large_omega_cv_limit,
 168                                             sigma_cv_limit => $large_sigma_cv_limit );
 169         if ( defined $l_se -> [$i] and
 170              defined $l_se -> [$i][$j] ) {
 171           my @large_standard_errors = @{$l_se -> [$i][$j]};
 172           my @found_cv = @{$f_cv -> [$i][$j]};
 173           if ( $#large_standard_errors < 0 ) {
 174             acknowledge( 'No large standard errors found', 'OK', $log );
 175           } else {
 176             acknowledge( 'Large standard errors found', 'WARNING', $log );
 177             for ( my $i = 0; $i <= $#large_standard_errors; $i++ ) {
 178               printf( "\t%-20s%10g\n", $large_standard_errors[$i], $found_cv[$i] );
 179               print $log sprintf( "\t%-20s%10g\n", $large_standard_errors[$i], $found_cv[$i] );
 180               print "\n" if ( $i == $#large_standard_errors );
 181               print $log "\n" if ( $i == $#large_standard_errors );
 182             }
 183           }
 184         }
 185
 186         my $eigens = $output -> eigens;
 187         if ( defined $eigens and
 188              defined $eigens -> [$i][$j] and
 189              scalar @{$eigens -> [$i][$j]} > 0 ) {
 190           if ( $output -> condition_number -> [$i][$j] < $condition_number_limit ) {
 191             acknowledge( 'Condition number ('.
 192                          sprintf("%6.1f",$output -> condition_number -> [$i][$j]).')', 'OK', $log );
 193           } else {
 194             acknowledge( 'Large condition number ('.
 195                          sprintf("%6.0f",$output -> condition_number -> [$i][$j]).')', 'WARNING', $log );
 196           }
 197         } else {
 198           $eigen_run = 0;
 199         }
 200
 201         if ( $output -> s_matrix_singular -> [$i][$j] ne '1' ) {
 202           acknowledge( 'S-matrix ', 'OK', $log );
 203         } else {
 204           acknowledge( 'S-matrix is singular', 'WARNING', $log );
 205         }
 206
 207         my ( $h_c, $f_c ) = $output -> high_correlations( limit => $correlation_limit );
 208         if ( defined $h_c -> [$i] and
 209              defined $h_c -> [$i][$j] ) {
 210           my @high_correlations = @{$h_c -> [$i][$j]};
 211           my @found_correlations = @{$f_c -> [$i][$j]};
 212           if ( $#high_correlations < 0 ) {
 213             acknowledge( 'Correlations', 'OK', $log );
 214           } else {
 215             acknowledge( 'Large correlations between parameter estimates found', 'WARNING', $log );
 216             for ( my $i = 0; $i <= $#high_correlations; $i++ ) {
 217               printf( "\t%-20s%10g\n", $high_correlations[$i],
 218                       $found_correlations[$i] );
 219               print $log sprintf( "\t%-20s%10g\n", $high_correlations[$i],
 220                                   $found_correlations[$i] );
 221               print "\n" if ( $i == $#high_correlations );
 222               print $log "\n" if ( $i == $#high_correlations );
 223             }
 224           }
 225         }
 226       }
 227     } else {
 228       print "No Covariance step run\n";
 229       print $log "No Covariance step run\n";
 230     }
 231   }
 232 }
 233
 234 close( $log );
 235
 236 #system( "sumo -confidence -c_level=95 $ARGV[0]" );
 237 system( "sumo $ARGV[0]" );
 238
 239