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|?",
  20              "help",
  21              "debug:0",
  22              "debug_package:s",
  23              "debug_subroutine:s",
  24              "compact_format:1",
  25              "csv",
  26              "precision:4",
  27              "confidence_interval",
  28              "c_level:95" );
  29
  30
  31 my $res = GetOptions( \%options, @opts );
  32
  33 exit unless $res;
  34
  35 if ( scalar( @ARGV ) < 1 and !($options{'h'} or $options{'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{'h'} or $options{'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{'help'} and !$options{'h'} ){
  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 foreach my $outfile ( @ARGV ) {
 128
 129     my $outobj = output -> new ('filename'=> $outfile);
 130
 131     unless( $outobj -> parsed_successfully ){
 132       print "Unable to read outputfile, parser error message:\n";
 133       print $outobj -> parsing_error_message();
 134     }
 135
 136     my @output_matrix;
 137     my @output_matrix_sizes;
 138
 139     my %c_levels = ( '90'   => 1.6449,
 140                      '95'   => 1.96,
 141                      '99'   => 2.5758,
 142                      '99.9' => 3.2905 );
 143
 144     if( $options{'confidence_interval'} ) {
 145         if( not defined $c_levels{$options{'c_level'}} ) {
 146             die "Sorry, confidence intervals for level ".$options{'c_level'}.
 147                 " can not be output. Valid levels are: ".join(',', keys %c_levels).
 148                 "\n";
 149         }
 150     }
 151
 152 #use Data::Dumper;
 153 #print Dumper( $outobj );
 154
 155     print "$outfile\n\n";
 156
 157     for( my $problems = 0; $problems <= $#{$outobj -> problems}; $problems++){
 158         my $row_counter = 0;
 159         for( my $sub_problems = 0; $sub_problems <= $#{$outobj -> problems -> [$problems] -> subproblems}; $sub_problems++){
 160
 161             my ( %nam, %est, %cest, %ses );
 162             my @thetas = defined $outobj -> thetas -> [$problems][$sub_problems] ? @{$outobj -> thetas -> [$problems][$sub_problems]} : ();
 163             my @thnam  = defined $outobj -> thetanames -> [$problems] ? @{$outobj -> thetanames -> [$problems]} : ();
 164             my @sethet = defined $outobj -> sethetas -> [$problems][$sub_problems] ? @{$outobj -> sethetas -> [$problems][$sub_problems]} : ();
 165             $nam{'theta'} = \@thnam;
 166             $est{'theta'} = \@thetas;
 167             $ses{'theta'} = \@sethet;
 168
 169
 170             my @omegas = defined $outobj -> omegas -> [$problems][$sub_problems] ? @{$outobj -> omegas -> [$problems][$sub_problems]} : ();
 171             my @comegas = defined $outobj -> comegas -> [$problems][$sub_problems] ? @{$outobj -> comegas -> [$problems][$sub_problems]} : ();
 172             my @omnam  = defined $outobj -> omeganames -> [$problems] ? @{$outobj -> omeganames -> [$problems]} : ();
 173             my @seomeg = defined $outobj -> seomegas -> [$problems][$sub_problems] ? @{$outobj -> seomegas -> [$problems][$sub_problems]} : ();
 174             $nam{'omega'} = \@omnam;
 175             $est{'omega'} = \@omegas;
 176             $cest{'omega'} = \@comegas;
 177             $ses{'omega'} = \@seomeg;
 178
 179             my @sigmas = defined $outobj -> sigmas -> [$problems][$sub_problems] ? @{$outobj -> sigmas -> [$problems][$sub_problems]} : ();
 180             my @csigmas = defined $outobj -> csigmas -> [$problems][$sub_problems] ? @{$outobj -> csigmas -> [$problems][$sub_problems]} : ();
 181             my @signam = defined $outobj -> sigmanames -> [$problems] ? @{$outobj -> sigmanames -> [$problems]} : ();
 182             my @sesigm = defined $outobj -> sesigmas -> [$problems][$sub_problems] ? @{$outobj -> sesigmas -> [$problems][$sub_problems]} : ();
 183             $nam{'sigma'} = \@signam;
 184             $est{'sigma'} = \@sigmas;
 185             $cest{'sigma'} = \@csigmas;
 186             $ses{'sigma'} = \@sesigm;
 187
 188             my $ofv    = $outobj -> ofv -> [$problems][$sub_problems];
 189             my $termess= $outobj -> minimization_message -> [$problems][$sub_problems];
 190
 191             if( $termess ){
 192                 print join( "",@{$termess} ), "\n";
 193             }
 194
 195             if ( defined $ofv ) {
 196                 print "Objective function value: ",$ofv,"\n\n";
 197             } else {
 198                 print "Objective function value: UNDEFINED\n\n";
 199             }
 200
 201             my @cvsethet;
 202             my @cvseomeg;
 203             my @cvsesigm;
 204
 205             if(@sethet) {
 206
 207               if( defined $outobj -> cvsethetas -> [$problems][$sub_problems] ) {
 208                 @cvsethet = @{$outobj -> cvsethetas -> [$problems][$sub_problems]};
 209               }
 210               if( defined $outobj -> cvseomegas -> [$problems][$sub_problems] ) {
 211                 @cvseomeg = @{$outobj -> cvseomegas -> [$problems][$sub_problems]};
 212               }
 213               if( defined $outobj -> cvsesigmas -> [$problems][$sub_problems] ) {
 214                 @cvsesigm = @{$outobj -> cvsesigmas -> [$problems][$sub_problems]};
 215               }
 216
 217             }
 218
 219             push( @{$output_matrix[$row_counter]}, "","THETA","","","OMEGA","","","SIGMA", "" );
 220             for( my $i = 0; $i <= $#{$output_matrix[$row_counter]}; $i++ ){
 221                 if( $output_matrix_sizes[$i] < length( $output_matrix[$row_counter][$i] ) ){
 222                     $output_matrix_sizes[$i] = length( $output_matrix[$row_counter][$i] );
 223                 }
 224             }
 225             $row_counter++;
 226
 227 #printf "%-4s %-29s %-29s %-18s\n"," ","THETA","OMEGA","SIGMA";
 228
 229             my $max_par = $#thetas;
 230             $max_par = $#omegas if ( $#omegas > $max_par );
 231             $max_par = $#sigmas if ( $#sigmas > $max_par );
 232
 233             for ( my $i = 0; $i <= $max_par; $i++ ) {
 234                 my ( @row, %cis );
 235                 if( $options{'confidence_interval'} ) {
 236                     foreach my $param ( 'theta', 'omega', 'sigma' ) {
 237                         if ( defined $est{$param}[$i] ) {
 238                             my $diff = $c_levels{$options{'c_level'}}*$ses{$param}[$i];
 239                             my ( $lo, $up );
 240                             if( defined $diff ) {
 241                                 $lo = $est{$param}[$i]-$diff;
 242                                 $up = $est{$param}[$i]+$diff;
 243                             }
 244                             my $cis = sprintf( "($form - $form)", $lo, $up );
 245                             push( @row, $nam{$param}[$i],
 246                                   sprintf( $form, $est{$param}[$i] ),
 247                                   $cis );
 248                         } else {
 249                             push( @row, '','','' );
 250                         }
 251                     }
 252                 } else {
 253                     if ( defined $thnam[$i] ) {
 254                         push( @row, $thnam[$i], defined $thetas[$i] ? sprintf( $form, $thetas[$i] ) : '........',
 255                               $cvsethet[$i] ? sprintf( "($form)", $cvsethet[$i] ) : '(........)' );
 256                     } else {
 257                         push( @row, '','','' );
 258                     }
 259                     if ( defined $omnam[$i] ) {
 260                         push( @row, $omnam[$i], defined $comegas[$i] ? sprintf( $form, $comegas[$i] ) : '........' ,
 261                               $cvseomeg[$i] ? sprintf( "($form)", $cvseomeg[$i] ) : '(........)' );
 262                     } else {
 263                         push( @row, '','','');
 264                     }
 265                     if ( defined $signam[$i] ) {
 266                         push( @row, $signam[$i], defined $sigmas[$i] ? sprintf( $form, $sigmas[$i] ) : '........',
 267                               $cvsesigm[$i] ? sprintf( "($form)", $cvsesigm[$i] ) : '(........)' );
 268                     } else {
 269                         push( @row, '','','');
 270                     }
 271                 }
 272
 273                 push(@{$output_matrix[$row_counter]}, @row);
 274                 for( my $i = 0; $i <= $#{$output_matrix[$row_counter]}; $i++ ){
 275                     if( $output_matrix_sizes[$i] < length( $output_matrix[$row_counter][$i] ) ){
 276                         $output_matrix_sizes[$i] = length( $output_matrix[$row_counter][$i] );
 277                     }
 278                 }
 279                 $row_counter++;
 280
 281             }
 282         }
 283     }
 284
 285 #for( my $j = 0; $j <= $#output_matrix; $j++ ){
 286 #  for( my $i = 0; $i <= $#{$output_matrix[$j]}; $i++ ){
 287 #    if( $output_matrix_sizes[$i] < length( $output_matrix[$j][$i] ) ){
 288 #      $output_matrix_sizes[$i] = length( $output_matrix[$j][$i] );
 289 #    }
 290 #  }
 291 #}
 292
 293     foreach my $row ( @output_matrix ){
 294         for( my $i = 0; $i <= $#{$row}; $i++ ){
 295             my $spaces = $output_matrix_sizes[$i] - length($row -> [$i]);
 296             if( $options{'csv'} ){
 297                 print $row -> [$i], ",";
 298             } else {
 299                 print " " x $spaces, $row -> [$i], "  ";
 300             }
 301         }
 302         print "\n";
 303     }
 304 }
 305
 306
 307 # my $pl = 1;
 308 # my @plist;
 309 # while($pl) {
 310 #   my $f = "";
 311 #   $pl = 0;
 312
 313 #   if(@thnam){
 314 #     push(@plist,shift @thnam);
 315 #     $pl = 1;
 316 #     $f.="%-4s ";
 317 #   } else {
 318 #     push(@plist," ");
 319 #     $f.="%-4s ";
 320 #   }
 321
 322 #   if(@thetas){
 323 #     push(@plist,shift @thetas);
 324 #     $pl = 1;
 325 #     $f.="%-10.4g ";
 326 #   } else {
 327 #     push(@plist," ");
 328 #     $f.="%-10s ";
 329 #   }
 330
 331 #   if(@cvsethet){
 332 #     push(@plist,"(".(sprintf "%.3g",shift @cvsethet).")");
 333 #     $pl = 1;
 334 #     $f.="%-12s ";
 335 #   } else {
 336 #     push @plist," " and $f.="%-12s ";
 337 #   }
 338
 339 #   if ( defined $omegas[0] ) {
 340 #   if(@omnam){
 341 # #     push(@om_str,shift @omnam);
 342 # #     $pl = 1;
 343 # #     $f .="%-5s ";
 344 # #   } else {
 345 # #     push(@om_str," ");
 346 # #     $f .="%-5s ";
 347 # #   }
 348
 349
 350 # #   my ( $omega, @om_str );
 351 # #   if(@omegas){
 352 # #     $omega = shift( @omegas );
 353 # #     unless( defined $omega and not $compact_format){
 354 # #       push( @om_str, "NaN" );
 355 # #       $f .= "%-10s ";
 356 # #     } elsif ( $omega != 0 or not $compact_format ) {
 357 # #       push(@om_str,$omega);
 358 # #       $pl = 1;
 359 # #       $f.="%-10.4g ";
 360 # #     }
 361 # #   } else {
 362 # #     push(@plist," ");
 363 # #     $f.="%-10s ";
 364 # #   }
 365
 366 # #   if(@cvseomeg){
 367 # #     my $cvseomega = shift( @cvseomeg );
 368 # #     if ( $omega != 0 ) {
 369 # #       push(@plist,"(".(sprintf "%.3g",$cvseomega).")");
 370 # #       $pl = 1;
 371 # #       $f.="%-8s ";
 372 # #     }
 373 # #   } else {
 374 # #     push(@plist," ");
 375 # #     $f.="%-8s ";
 376 # #   }
 377
 378 #   if(@signam){
 379 #     push(@plist,shift @signam);
 380 #     $pl = 1;
 381 #     $f .="%-4s ";
 382 #   } else {
 383 #     push(@plist," ");
 384 #     $f .="%-4s ";
 385 #   }
 386
 387 #   if(@sigmas){
 388 #     push(@plist,shift @sigmas);
 389 #     $pl = 1;
 390 #     $f.="%-10.4g ";
 391 #   } else {
 392 #     push(@plist," ");
 393 #     $f.="%-10s";
 394 #   }
 395
 396 #   if(@cvsesigm) {
 397 #     push(@plist,"(".(sprintf "%.3g",shift @cvsesigm).")");
 398 #     $pl = 1;
 399 #     $f.="%-8s ";
 400 #   } else {
 401 #     push(@plist," ");
 402 #     $f.="%-8s ";
 403 #   }
 404
 405 #   $f .="\n";
 406
 407 #   if($pl) {
 408 #     printf $f,@plist;
 409 #   }
 410 #   undef @plist;
 411 # }
 412
 413
 414