bin/sumo

   1 #!/usr/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 output;
  11 use debug;
  12 use strict;
  13 use Getopt::Long;
  14
  15 my %options;
  16
  17 $options{'precision'} = 4;
  18
  19 my $opts = { "h|?"                 => $options{'help'},
  20              "help"                => $options{'long_help'},
  21              "debug:0"             => $options{'debug'},
  22              "debug_package:s"     => $options{'debug_package'},
  23              "debug_subroutine:s"  => $options{'debug_subroutine'},
  24              "compact_format:1"    => $options{'compact_format'},
  25              "csv"                 => $options{'csv'},
  26              "precision:4"         => $options{'precision'},
  27              "confidence_interval" => $options{'confidence_interval'},
  28              "c_level:95"          => $options{'c_level'} };
  29
  30
  31 my $res = GetOptions( \%options, %{$opts} );
  32
  33 exit unless $res;
  34
  35 if ( scalar( @ARGV ) < 1 and !($options{'help'} or $options{'long_help'}) ){
  36   print "At least one list file must be specified. Use 'sumo.pl -h' for help.\n";
  37   exit;
  38 }
  39
  40
  41 if($options{'help'} or $options{'long_help'}) {
  42   print <<'ENDHELP';
  43
  44   sumo.pl
  45
  46   Perl script for summarizing output data.
  47
  48   Usage:
  49
  50   sumo.pl [ -h | -? ] [ -help ]
  51           [ -debug='integer' ]
  52           [ -debug_package='string' ]
  53           [ -debug_subroutine='string' ]
  54           outputfile(s)
  55
  56 ENDHELP
  57
  58   if( $options{'long_help'} and !$options{'help'} ){
  59
  60     print <<'ENDHELP';
  61
  62   Description:
  63
  64     Sumo is short for SUmmarize Output. And it does exactly that. It
  65     gathers some usefull information from NONMEM ouputfiles and prints
  66     a summary to screen.
  67
  68   Examples:
  69
  70     Get summary from an output file:
  71
  72     $ sumo.pl output.lst
  73
  74   Options:
  75
  76     The following options are valid:
  77
  78     -h | -?
  79
  80     Print a list of options.
  81
  82
  83     -help
  84
  85     Print this, longer, help message.
  86
  87
  88         -debug='integer'
  89
  90     Default value is: 0
  91
  92     This is mainly for developers who whish to debug PsN. By default
  93     'integer' is zero but you can try setting it to '1' and you might
  94     get some helpfull warnings. If you run in to problems that require
  95     support, you might be told to crank this number up and send the
  96     output to us.
  97
  98
  99     -debug_package='string'
 100
 101     Default value is: empty string
 102
 103     If use together with '-debug' it is possible to choose which part
 104     of PsN you want to see debug messages from. Again this is mostly
 105     for developers.
 106
 107
 108     -debug_subroutine='string'
 109
 110     Default value is: empty string
 111
 112     With this option it is possible to specify, with even finer
 113     granularity, which part of PsN you want to see debug messages
 114     from. This is definitly only for developers.
 115
 116 ENDHELP
 117   }
 118   exit;
 119 }
 120
 121 debug -> level( $options{'debug'} );
 122 debug -> package( $options{'debug_package'} );
 123 debug -> subroutine( $options{'debug_subroutine'} );
 124
 125 my $form = '%.' . $options{'precision'} . 'g';
 126
 127 my $outfile = $ARGV[0];
 128
 129 my $outobj = output -> new ('filename'=> $outfile);
 130
 131 my @output_matrix;
 132 my @output_matrix_sizes;
 133
 134 my %c_levels = ( '90'   => 1.6449,
 135                  '95'   => 1.96,
 136                  '99'   => 2.5758,
 137                  '99.9' => 3.2905 );
 138
 139 if( $options{'confidence_interval'} ) {
 140   if( not defined $c_levels{$options{'c_level'}} ) {
 141     die "Sorry, confidence intervals for level ".$options{'c_level'}.
 142         " can not be output. Valid levels are: ".join(',', keys %c_levels).
 143         "\n";
 144   }
 145 }
 146
 147 #use Data::Dumper;
 148 #print Dumper( $outobj );
 149
 150 print "$outfile\n\n";
 151
 152 for( my $problems = 0; $problems <= $#{$outobj -> problems}; $problems++){
 153   my $row_counter = 0;
 154   for( my $sub_problems = 0; $sub_problems <= $#{$outobj -> problems -> [$problems] -> subproblems}; $sub_problems++){
 155
 156     my ( %nam, %est, %cest, %ses );
 157     my @thetas = defined $outobj -> thetas -> [$problems][$sub_problems] ? @{$outobj -> thetas -> [$problems][$sub_problems]} : ();
 158     my @thnam  = defined $outobj -> thetanames -> [$problems] ? @{$outobj -> thetanames -> [$problems]} : ();
 159     my @sethet = defined $outobj -> sethetas -> [$problems][$sub_problems] ? @{$outobj -> sethetas -> [$problems][$sub_problems]} : ();
 160     $nam{'theta'} = \@thnam;
 161     $est{'theta'} = \@thetas;
 162     $ses{'theta'} = \@sethet;
 163
 164
 165     my @omegas = defined $outobj -> omegas -> [$problems][$sub_problems] ? @{$outobj -> omegas -> [$problems][$sub_problems]} : ();
 166     my @comegas = defined $outobj -> comegas -> [$problems][$sub_problems] ? @{$outobj -> comegas -> [$problems][$sub_problems]} : ();
 167     my @omnam  = defined $outobj -> omeganames -> [$problems] ? @{$outobj -> omeganames -> [$problems]} : ();
 168     my @seomeg = defined $outobj -> seomegas -> [$problems][$sub_problems] ? @{$outobj -> seomegas -> [$problems][$sub_problems]} : ();
 169     $nam{'omega'} = \@omnam;
 170     $est{'omega'} = \@omegas;
 171     $cest{'omega'} = \@comegas;
 172     $ses{'omega'} = \@seomeg;
 173
 174     my @sigmas = defined $outobj -> sigmas -> [$problems][$sub_problems] ? @{$outobj -> sigmas -> [$problems][$sub_problems]} : ();
 175     my @csigmas = defined $outobj -> csigmas -> [$problems][$sub_problems] ? @{$outobj -> csigmas -> [$problems][$sub_problems]} : ();
 176     my @signam = defined $outobj -> sigmanames -> [$problems] ? @{$outobj -> sigmanames -> [$problems]} : ();
 177     my @sesigm = defined $outobj -> sesigmas -> [$problems][$sub_problems] ? @{$outobj -> sesigmas -> [$problems][$sub_problems]} : ();
 178     $nam{'sigma'} = \@signam;
 179     $est{'sigma'} = \@sigmas;
 180     $cest{'sigma'} = \@csigmas;
 181     $ses{'sigma'} = \@sesigm;
 182
 183     my $ofv    = $outobj -> ofv -> [$problems][$sub_problems];
 184     my $termess= $outobj -> minimization_message -> [$problems][$sub_problems];
 185
 186     if( $termess ){
 187       print join( "",@{$termess} ), "\n";
 188     }
 189
 190     if ( defined $ofv ) {
 191       print "Objective function value: ",$ofv,"\n\n";
 192     } else {
 193       print "Objective function value: UNDEFINED\n\n";
 194     }
 195
 196     my @cvsethet;
 197     my @cvseomeg;
 198     my @cvsesigm;
 199
 200     if(@sethet) {
 201
 202       @cvsethet = @{$outobj -> cvsethetas -> [$problems][$sub_problems]};
 203       @cvseomeg = @{$outobj -> cvseomegas -> [$problems][$sub_problems]};
 204       @cvsesigm = @{$outobj -> cvsesigmas -> [$problems][$sub_problems]};
 205
 206     }
 207
 208     push( @{$output_matrix[$row_counter]}, "","THETA","","","OMEGA","","","SIGMA", "" );
 209     for( my $i = 0; $i <= $#{$output_matrix[$row_counter]}; $i++ ){
 210       if( $output_matrix_sizes[$i] < length( $output_matrix[$row_counter][$i] ) ){
 211         $output_matrix_sizes[$i] = length( $output_matrix[$row_counter][$i] );
 212       }
 213     }
 214     $row_counter++;
 215
 216 #printf "%-4s %-29s %-29s %-18s\n"," ","THETA","OMEGA","SIGMA";
 217
 218     my $max_par = $#thetas;
 219     $max_par = $#omegas if ( $#omegas > $max_par );
 220     $max_par = $#sigmas if ( $#sigmas > $max_par );
 221
 222     for ( my $i = 0; $i <= $max_par; $i++ ) {
 223       my ( @row, %cis );
 224       if( $options{'confidence_interval'} ) {
 225         foreach my $param ( 'theta', 'omega', 'sigma' ) {
 226           if ( defined $est{$param}[$i] ) {
 227             my $diff = $c_levels{$options{'c_level'}}*$ses{$param}[$i];
 228             my ( $lo, $up );
 229             if( defined $diff ) {
 230               $lo = $est{$param}[$i]-$diff;
 231               $up = $est{$param}[$i]+$diff;
 232             }
 233             my $cis = sprintf( "($form - $form)", $lo, $up );
 234             push( @row, $nam{$param}[$i],
 235                   sprintf( $form, $est{$param}[$i] ),
 236                   $cis );
 237           } else {
 238             push( @row, '','','' );
 239           }
 240         }
 241       } else {
 242         if ( defined $thnam[$i] ) {
 243           push( @row, $thnam[$i], defined $thetas[$i] ? sprintf( $form, $thetas[$i] ) : '........',
 244                 $cvsethet[$i] ? sprintf( "($form)", $cvsethet[$i] ) : '(........)' );
 245         } else {
 246           push( @row, '','','' );
 247         }
 248         if ( defined $omnam[$i] ) {
 249           push( @row, $omnam[$i], defined $comegas[$i] ? sprintf( $form, $comegas[$i] ) : '........' ,
 250                 $cvseomeg[$i] ? sprintf( "($form)", $cvseomeg[$i] ) : '(........)' );
 251         } else {
 252           push( @row, '','','');
 253         }
 254         if ( defined $signam[$i] ) {
 255           push( @row, $signam[$i], defined $sigmas[$i] ? sprintf( $form, $sigmas[$i] ) : '........',
 256                 $cvsesigm[$i] ? sprintf( "($form)", $cvsesigm[$i] ) : '(........)' );
 257         } else {
 258           push( @row, '','','');
 259         }
 260       }
 261
 262       push(@{$output_matrix[$row_counter]}, @row);
 263       for( my $i = 0; $i <= $#{$output_matrix[$row_counter]}; $i++ ){
 264         if( $output_matrix_sizes[$i] < length( $output_matrix[$row_counter][$i] ) ){
 265           $output_matrix_sizes[$i] = length( $output_matrix[$row_counter][$i] );
 266         }
 267       }
 268       $row_counter++;
 269
 270     }
 271   }
 272 }
 273
 274 #for( my $j = 0; $j <= $#output_matrix; $j++ ){
 275 #  for( my $i = 0; $i <= $#{$output_matrix[$j]}; $i++ ){
 276 #    if( $output_matrix_sizes[$i] < length( $output_matrix[$j][$i] ) ){
 277 #      $output_matrix_sizes[$i] = length( $output_matrix[$j][$i] );
 278 #    }
 279 #  }
 280 #}
 281
 282 foreach my $row ( @output_matrix ){
 283   for( my $i = 0; $i <= $#{$row}; $i++ ){
 284     my $spaces = $output_matrix_sizes[$i] - length($row -> [$i]);
 285     if( $options{'csv'} ){
 286       print $row -> [$i], ",";
 287     } else {
 288       print " " x $spaces, $row -> [$i], "  ";
 289     }
 290   }
 291   print "\n";
 292 }
 293
 294
 295
 296 # my $pl = 1;
 297 # my @plist;
 298 # while($pl) {
 299 #   my $f = "";
 300 #   $pl = 0;
 301
 302 #   if(@thnam){
 303 #     push(@plist,shift @thnam);
 304 #     $pl = 1;
 305 #     $f.="%-4s ";
 306 #   } else {
 307 #     push(@plist," ");
 308 #     $f.="%-4s ";
 309 #   }
 310
 311 #   if(@thetas){
 312 #     push(@plist,shift @thetas);
 313 #     $pl = 1;
 314 #     $f.="%-10.4g ";
 315 #   } else {
 316 #     push(@plist," ");
 317 #     $f.="%-10s ";
 318 #   }
 319
 320 #   if(@cvsethet){
 321 #     push(@plist,"(".(sprintf "%.3g",shift @cvsethet).")");
 322 #     $pl = 1;
 323 #     $f.="%-12s ";
 324 #   } else {
 325 #     push @plist," " and $f.="%-12s ";
 326 #   }
 327
 328 #   if ( defined $omegas[0] ) {
 329 #   if(@omnam){
 330 # #     push(@om_str,shift @omnam);
 331 # #     $pl = 1;
 332 # #     $f .="%-5s ";
 333 # #   } else {
 334 # #     push(@om_str," ");
 335 # #     $f .="%-5s ";
 336 # #   }
 337
 338
 339 # #   my ( $omega, @om_str );
 340 # #   if(@omegas){
 341 # #     $omega = shift( @omegas );
 342 # #     unless( defined $omega and not $compact_format){
 343 # #       push( @om_str, "NaN" );
 344 # #       $f .= "%-10s ";
 345 # #     } elsif ( $omega != 0 or not $compact_format ) {
 346 # #       push(@om_str,$omega);
 347 # #       $pl = 1;
 348 # #       $f.="%-10.4g ";
 349 # #     }
 350 # #   } else {
 351 # #     push(@plist," ");
 352 # #     $f.="%-10s ";
 353 # #   }
 354
 355 # #   if(@cvseomeg){
 356 # #     my $cvseomega = shift( @cvseomeg );
 357 # #     if ( $omega != 0 ) {
 358 # #       push(@plist,"(".(sprintf "%.3g",$cvseomega).")");
 359 # #       $pl = 1;
 360 # #       $f.="%-8s ";
 361 # #     }
 362 # #   } else {
 363 # #     push(@plist," ");
 364 # #     $f.="%-8s ";
 365 # #   }
 366
 367 #   if(@signam){
 368 #     push(@plist,shift @signam);
 369 #     $pl = 1;
 370 #     $f .="%-4s ";
 371 #   } else {
 372 #     push(@plist," ");
 373 #     $f .="%-4s ";
 374 #   }
 375
 376 #   if(@sigmas){
 377 #     push(@plist,shift @sigmas);
 378 #     $pl = 1;
 379 #     $f.="%-10.4g ";
 380 #   } else {
 381 #     push(@plist," ");
 382 #     $f.="%-10s";
 383 #   }
 384
 385 #   if(@cvsesigm) {
 386 #     push(@plist,"(".(sprintf "%.3g",shift @cvsesigm).")");
 387 #     $pl = 1;
 388 #     $f.="%-8s ";
 389 #   } else {
 390 #     push(@plist," ");
 391 #     $f.="%-8s ";
 392 #   }
 393
 394 #   $f .="\n";
 395
 396 #   if($pl) {
 397 #     printf $f,@plist;
 398 #   }
 399 #   undef @plist;
 400 # }
 401
 402
 403