lib/output/problem_subs.pm

   1 # {{{ include
   2
   3 start include statements
   4     # No brackets!
   5         use Data::Dumper;
   6         my $nrec_exp = '^\s*NO. OF DATA RECS IN DATA SET:\s*(\d*)|^\s*TOT. NO. OF DATA RECS:\s*(\d*)';
   7         my $nobs_exp = ' TOT. NO. OF OBS RECS:\s*(\d*)';
   8         my $nind_exp = ' TOT. NO. OF INDIVIDUALS:\s*(\d*)';
   9         my $subprob_exp = '^ PROBLEM NO\.:\s*\d+\s*SUBPROBLEM NO\.:\s*(\d+)';
  10         use Config;
  11 end include
  12
  13 # }}} include statements
  14
  15 # {{{ new
  16
  17 start new
  18       {
  19         # Read Global data
  20         $this -> _read_nrecs();
  21         $this -> _read_nobs()             if ( $this -> parsed_successfully() and not
  22                                                $this -> finished_parsing() );
  23         $this -> _read_nind()             if ( $this -> parsed_successfully() and not
  24                                                $this -> finished_parsing() );
  25         $this -> _read_msfo_status()      if ( $this -> parsed_successfully() and not
  26                                                $this -> finished_parsing() );
  27         $this -> _read_block_structures() if ( $this -> parsed_successfully() and not
  28                                                $this -> finished_parsing() );
  29         $this -> _read_inits()            if ( $this -> parsed_successfully() and not
  30                                                $this -> finished_parsing() );
  31         $this -> _read_eststep()          if ( $this -> parsed_successfully() and not
  32                                                $this -> finished_parsing() );
  33         $this -> _read_nonpstep()         if ( $this -> parsed_successfully() and not
  34                                                $this -> finished_parsing() );
  35         $this -> _read_covstep()          if ( $this -> parsed_successfully() and not
  36                                                $this -> finished_parsing() );
  37         $this -> _read_tablesstep()       if ( $this -> parsed_successfully() and not
  38                                                $this -> finished_parsing() );
  39         $this -> _read_prior()            if ( $this -> parsed_successfully() and not
  40                                                $this -> finished_parsing() );
  41         $this -> _read_steps_allowed()    if ( $this -> parsed_successfully() and not
  42                                                $this -> finished_parsing() );
  43         $this -> _read_subproblems()      if ( $this -> parsed_successfully() and not
  44                                                $this -> finished_parsing() );
  45         my $mes = $this -> parsing_error_message();
  46         if( defined $this -> subproblems() ) {
  47           foreach my $subp ( @{$this -> subproblems()} ) {
  48             $mes .= $subp -> parsing_error_message();
  49             $this -> parsed_successfully($this -> parsed_successfully() *
  50                                          $subp -> parsed_successfully());
  51           }
  52         }
  53
  54         $this -> parsing_error_message( $mes );
  55
  56         if ( defined $this -> {'subproblems'} and $this -> parsed_successfully() ) {
  57           $this -> _set_labels;
  58         }
  59
  60         delete $this -> {'lstfile'};
  61       }
  62 end new
  63
  64 # }}} new
  65
  66 # {{{ parsing_error
  67 start parsing_error
  68     $self -> parsed_successfully( 0 );
  69 $self -> parsing_error_message( $message );
  70 end parsing_error
  71 # }}} parsing_error
  72
  73 # {{{ register_in_database
  74
  75 start register_in_database
  76     if ( $PsN::config -> {'_'} -> {'use_database'} ) {
  77       my ( $date_str, $time_str );
  78       if ( $Config{osname} eq 'MSWin32' ) {
  79         $date_str = `date /T`;
  80         $time_str = ' '.`time /T`;
  81       } else {
  82         # Assuming UNIX
  83         $date_str = `date`;
  84       }
  85       chomp($date_str);
  86       chomp($time_str);
  87       my $date_time = $date_str.$time_str;
  88       my $dbh = DBI -> connect("DBI:mysql:host=".$PsN::config -> {'_'} -> {'database_server'}.
  89                                ";databse=".$PsN::config -> {'_'} -> {'project'},
  90                                $PsN::config -> {'_'} -> {'user'},
  91                                 $PsN::config -> {'_'} -> {'password'},
  92                                {'RaiseError' => 1});
  93       my $sth;
  94       my @mod_str = ('','');
  95       if ( defined $self -> {'model_id'} ) {
  96         @mod_str = ('model_id, ',"$self->{'model_id'}, ");
  97       }
  98       $sth = $dbh -> prepare("INSERT INTO ".$PsN::config -> {'_'} -> {'project'}.
  99                                ".oproblem ".
 100                              "(output_id,".
 101                              $mod_str[0].
 102                              "nrecs,nobs,nind) ".
 103                              "VALUES ( '$output_id' ,".
 104                              $mod_str[1].
 105                              "'$self->{'nrecs'}' ".
 106                              ",'$self->{'nobs'}' ,'$self->{'nind'}' )");
 107       $sth -> execute;
 108       $self -> {'problem_id'} = $sth->{'mysql_insertid'};
 109       $sth -> finish;
 110       $dbh -> disconnect;
 111       if ( defined $self -> {'problem_id'} ) {
 112         foreach my $problem ( @{$self -> {'subproblems'}} ) {
 113           $problem -> register_in_database( output_id  => $output_id,
 114                                             problem_id => $self -> {'problem_id'},
 115                                             model_id   => $model_id );
 116         }
 117       }
 118     }
 119 end register_in_database
 120
 121 # }}} register_in_database
 122
 123 # {{{ _read_subproblems
 124 start _read_subproblems
 125     my $subproblem_start;
 126 while ( $_ = @{$self -> {'lstfile'}}[ $self -> {'lstfile_pos'}++ ] ) {
 127   if( /$subprob_exp/ or $self -> {'lstfile_pos'} > $#{$self -> {'lstfile'}} ){
 128     if( defined $subproblem_start ){
 129       my @subproblem_lstfile =
 130           @{$self -> {'lstfile'}}[$subproblem_start .. $self -> {'lstfile_pos'} - 2];
 131       my $subproblems;
 132       if( $self -> {'lstfile_pos'} > $#{$self -> {'lstfile'}} ) {
 133         $subproblems = $2;
 134       } else {
 135         $subproblems = $2 - 1; # Assuming problems come in order
 136       }
 137       $self -> add_subproblem
 138           ( 'init_data' => {lstfile                    => \@subproblem_lstfile,
 139                             estimation_step_initiated  => $self -> estimation_step_initiated(),
 140                             estimation_step_run        => $self -> estimation_step_run(),
 141                             nonparametric_step_run     => $self -> {'nonparametric_step_run'},
 142                             covariance_step_run        => $self -> {'covariance_step_run'},
 143                             msfi_used                  => $self -> msfi_used(),
 144                             omega_block_structure_type => $self -> {'omega_block_structure_type'},
 145                             sigma_block_structure_type => $self -> {'sigma_block_structure_type'},
 146                             omega_block_structure      => $self -> {'omega_block_structure'},
 147                             sigma_block_structure      => $self -> {'sigma_block_structure'},
 148                             omega_block_sets           => $self -> {'omega_block_sets'},
 149                             sigma_block_sets           => $self -> {'sigma_block_sets'},
 150                             estimated_thetas           => $self -> {'estimated_thetas'},
 151                             estimated_omegas           => $self -> {'estimated_omegas'},
 152                             estimated_sigmas           => $self -> {'estimated_sigmas'},
 153 #                                 lower_theta_bounds         => $self -> {'lower_theta_bounds'},
 154 #                                 upper_theta_bounds         => $self -> {'upper_theta_bounds'},
 155                             tablename                  => @{$self -> {'tablenames'}}[$subproblems],
 156                             tableidcolumn              => @{$self -> {'tableidcolumns'}}[$subproblems],
 157                             model_id                   => $self -> {'model_id'},
 158                             problem_id                 => $self -> {'problem_id'},
 159                             output_id                  => $self -> {'output_id'} });
 160     }
 161     unless ( $self -> {'lstfile_pos'} > $#{$self -> {'lstfile'}} ){
 162       $subproblem_start = $self -> {'lstfile_pos'};
 163     }
 164   }
 165 }
 166
 167 unless( defined $subproblem_start ) { # No subproblems. Try to make one from the whole file.
 168   $self -> add_subproblem
 169       ( 'init_data' => {lstfile                    => $self -> {'lstfile'},
 170                         estimation_step_initiated  => $self -> estimation_step_initiated(),
 171                         estimation_step_run        => $self -> estimation_step_run(),
 172                         nonparametric_step_run     => $self -> {'nonparametric_step_run'},
 173                         covariance_step_run        => $self -> {'covariance_step_run'},
 174                         msfi_used                  => $self -> msfi_used(),
 175                         omega_block_structure_type => $self -> {'omega_block_structure_type'},
 176                         sigma_block_structure_type => $self -> {'sigma_block_structure_type'},
 177                         omega_block_structure      => $self -> {'omega_block_structure'},
 178                         sigma_block_structure      => $self -> {'sigma_block_structure'},
 179                         omega_block_sets           => $self -> {'omega_block_sets'},
 180                         sigma_block_sets           => $self -> {'sigma_block_sets'},
 181                         estimated_thetas           => $self -> {'estimated_thetas'},
 182                         estimated_omegas           => $self -> {'estimated_omegas'},
 183                         estimated_sigmas           => $self -> {'estimated_sigmas'},
 184 #                             lower_theta_bounds         => $self -> {'lower_theta_bounds'},
 185 #                             upper_theta_bounds         => $self -> {'upper_theta_bounds'},
 186                         tablename                  => @{$self -> {'tablenames'}}[0],
 187                         tableidcolumn              => @{$self -> {'tableidcolumns'}}[0],
 188                         model_id                   => $self -> {'model_id'},
 189                         problem_id                 => $self -> {'problem_id'},
 190                         output_id                  => $self -> {'output_id'} } );
 191 }
 192
 193 end _read_subproblems
 194 # }}} _read_subproblems
 195
 196 # {{{ _read_nrecs
 197 start _read_nrecs
 198 # The data recs statement should always be present
 199 # Raise parsing error if not found
 200     my $errmess = "Error in reading the number of data records!\n";
 201 my $start_pos = $self -> {'lstfile_pos'};
 202 my $success  = 0;
 203
 204 while ( $_ = @{$self -> {'lstfile'}}[$start_pos++] ) {
 205   if ( /$nobs_exp/ or ($start_pos + 1) == scalar @{$self -> {'lstfile'}} ) {
 206     debug -> warn( level => 1,
 207                    message => $errmess."$!" );
 208     $self -> parsing_error( message => $errmess."$!" );
 209     return;
 210   }
 211   if ( /$nrec_exp/ ) {
 212     $self -> nrecs($1);
 213     $success = 1;
 214     last;
 215   }
 216 }
 217 if ( $success ) {
 218   $self -> {'lstfile_pos'} = $start_pos;
 219 } else {
 220     debug -> warn( level => 1,
 221                    message => $errmess."$!" );
 222     $self -> parsing_error( message => $errmess."$!" );
 223 }
 224 end _read_nrecs
 225 # }}} _read_nrecs
 226
 227 # {{{ _read_nobs
 228 start _read_nobs
 229 # The no of obs recs statement should always be present
 230 # Raise parsing error if not found
 231     my $errmess = "Error in reading the number of observation records!\n";
 232 my $start_pos = $self -> {'lstfile_pos'};
 233 my $success  = 0;
 234
 235 while ( $_ = @{$self -> {'lstfile'}}[$start_pos++] ) {
 236   if ( /$nind_exp/ or ($start_pos + 1) == scalar @{$self -> {'lstfile'}} ) {
 237     debug -> warn( level => 1,
 238                    message => $errmess."$!" );
 239     $self -> parsing_error( message => $errmess."$!" );
 240     return;
 241   }
 242   if ( /$nobs_exp/ ) {
 243     $self -> nobs($1);
 244     $success = 1;
 245     last;
 246   }
 247 }
 248 if ( $success ) {
 249   $self -> {'lstfile_pos'} = $start_pos;
 250 } else {
 251   debug -> warn( level => 1,
 252                  message => $errmess."$!" );
 253   $self -> parsing_error( message => $errmess."$!" );
 254 }
 255 end _read_nobs
 256 # }}} _read_nobs
 257
 258 # {{{ _read_nind
 259 start _read_nind
 260 # The no of individuals statement should always be present
 261 # Raise parsing error if not found
 262     my $errmess = "Error in reading the number of individuals!\n";
 263 my $start_pos = $self -> {'lstfile_pos'};
 264 my $success  = 0;
 265
 266 while ( $_ = @{$self -> {'lstfile'}}[$start_pos++] ) {
 267   if ( /^0LENGTH OF THETA/ or
 268        /^0MODEL SPECIFICATION FILE INPUT/ or
 269        ($start_pos + 1) == scalar @{$self -> {'lstfile'}} ) {
 270     debug -> warn( level => 1,
 271                    message => $errmess."$!" );
 272     $self -> parsing_error( message => $errmess."$!" );
 273     return;
 274   }
 275   if ( /$nind_exp/ ) {
 276     $self -> nind($1);
 277     $success = 1;
 278     last;
 279   }
 280 }
 281 if ( $success ) {
 282   $self -> {'lstfile_pos'} = $start_pos;
 283 } else {
 284   debug -> warn( level => 1,
 285                  message => $errmess."$!" );
 286   $self -> parsing_error( message => $errmess."$!" );
 287 }
 288 end _read_nind
 289 # }}} _read_nind
 290
 291 # {{{ _read_arbitrary
 292
 293 start _read_arbitrary
 294 {
 295     my $start_pos = $self -> {'lstfile_pos'};
 296     my $success  = 0;
 297
 298     while ( $_ = @{$self -> {'lstfile'}}[$start_pos++] ) {
 299         last if ( /^ PROBLEM.*SUBPROBLEM/ or /^ PROBLEM NO\.:\s+\d/ );
 300         if ( /$regexp/ ) {
 301             $self -> { $member } = $1;
 302             $success = 1;
 303             last;
 304         }
 305     }
 306     if ( $success ) {
 307         $self -> {'lstfile_pos'} = $start_pos;
 308     } else {
 309         debug -> warn( level   => 1,
 310                        message => "rewinding to first position..." );
 311     }
 312 }
 313 end _read_arbitrary
 314
 315 # }}} _read_arbitrary
 316
 317 # {{{ _read_msfo_status
 318 start _read_msfo_status
 319 {
 320   my $start_pos = $self -> {'lstfile_pos'};
 321   while( $_ = @{$self -> {'lstfile'}}[ $start_pos++ ] ) {
 322
 323     if( /^0SEARCH WITH ESTIMATION STEP WILL NOT PROCEED BEYOND PREVIOUS TERMINATION POINT/ ){
 324       $self -> msfo_has_terminated(1); # Means that $ESTIMATION
 325                                             # must be removed to enable continuation.
 326       $self -> finished_parsing(1);
 327     }
 328
 329     if( /^0MODEL SPECIFICATION FILE IS EMPTY/ ){
 330       $self -> {'msfo_file_empty'} = 1;
 331       $self -> finished_parsing(1);
 332     }
 333   }
 334 }
 335 end _read_msfo_status
 336 # }}}
 337
 338 # {{{ _read_block_structures
 339
 340 start _read_block_structures
 341 # These structures should always be present if no model specification file input is used
 342 # Raise parsing error if not found
 343 # $success is not used, really, with the latest fix
 344       {
 345         my $errmess = "Error in reading the block structures!";
 346         my $start_pos = $self -> {'lstfile_pos'};
 347         my $success  = 1;
 348
 349         my $obarea = 0;
 350         my $sbarea = 0;
 351
 352         my $oblock_set = -1;
 353         my $sblock_set = -1;
 354         while( $_ = @{$self -> {'lstfile'}}[ $start_pos++ ] ) {
 355           if ( /^0MODEL SPECIFICATION FILE INPUT/ ) {
 356             # We can't find anything but that's ok
 357             $success = 1;
 358             $start_pos--;
 359             last;
 360           }
 361
 362           if ( /^0INITIAL ESTIMATE/ or /^0DEFAULT OMEGA BOUNDARY TEST OMITTED:/ ) {
 363             # We want to find this if we are currently reading omega
 364             # or sigma block structures
 365             $success = 1 if ( $sbarea or $obarea );
 366             $start_pos --;
 367             last;
 368           }
 369
 370           if ( ($start_pos + 1) == scalar @{$self -> {'lstfile'}} ) {
 371             #EOF This should not happen, raise error
 372             my $errmess = "Reached end of file while parsing block structures\n";
 373             debug -> warn( level => 1,
 374                            message => $errmess."$!" );
 375             $self -> parsing_error( message => $errmess."$!" );
 376             return;
 377           }
 378
 379           if(/0OMEGA HAS BLOCK FORM:/) {
 380             $self -> {'omega_block_structure_type'} = 'BLOCK';
 381             $obarea = 1;
 382             $success = 1;
 383             next;
 384           }
 385           if(/0SIGMA HAS BLOCK FORM:/) {
 386             $self -> {'sigma_block_structure_type'} = 'BLOCK';
 387             $sbarea = 1;
 388             $obarea = 0;
 389             $success = 1;
 390             next;
 391           }
 392           if ( /^0OMEGA HAS SIMPLE DIAGONAL FORM/ ) {
 393             $self -> {'omega_block_structure_type'} = 'DIAGONAL';
 394             $success = 1;
 395             next;
 396           }
 397           if ( /^0SIGMA HAS SIMPLE DIAGONAL FORM/ ) {
 398             $self -> {'sigma_block_structure_type'} = 'DIAGONAL';
 399             $success = 1;
 400             last;
 401           }
 402           if ( $obarea ) {
 403             my @row = split;
 404             # All rows with the last but one element set to 0 indicate the start of a new block
 405             # $#row == 0 indicates the first row of the matrix.
 406             if ( $#row == 0 or $row[$#row-1] == 0 ) {
 407               # If the same number as previous set
 408               if ( $oblock_set == $row[$#row] ) {
 409                 $self -> {'omega_block_sets'}{$oblock_set}{'size'}++;
 410               } else {
 411                 $oblock_set = $row[$#row];
 412                 $self -> {'omega_block_sets'}{$oblock_set}{'size'} = 1;
 413               }
 414               # Always set dimension to 1 when starting a new block
 415               $self -> {'omega_block_sets'}{$oblock_set}{'dimension'} = 1;
 416             } else {
 417               $self -> {'omega_block_sets'}{$oblock_set}{'dimension'}++;
 418             }
 419             push( @{$self -> {'omega_block_structure'}}, \@row );
 420           }
 421           if ( $sbarea ) {
 422             my @row = split;
 423             # All rows with the last but one element set to 0 indicate the start of a new block
 424             if ( $#row == 0 or $row[$#row-1] == 0 ) {
 425               # If the same number as previous set
 426               if ( $sblock_set == $row[$#row] ) {
 427                 $self -> {'sigma_block_sets'}{$sblock_set}{'size'}++;
 428               } else {
 429                 $sblock_set = $row[$#row];
 430                 $self -> {'sigma_block_sets'}{$sblock_set}{'size'} = 1;
 431               }
 432               # Always set dimension to 1 when starting a new block
 433               $self -> {'sigma_block_sets'}{$sblock_set}{'dimension'} = 1;
 434             } else {
 435               $self -> {'sigma_block_sets'}{$sblock_set}{'dimension'}++;
 436             }
 437             push( @{$self -> {'sigma_block_structure'}}, \@row );
 438           }
 439         }
 440
 441         unless( defined $self -> {'omega_block_structure_type'} ){
 442           $self -> {'omega_block_structure_type'} = 'DIAGONAL';
 443         }
 444         unless( defined $self -> {'sigma_block_structure_type'} ){
 445           $self -> {'sigma_block_structure_type'} = 'DIAGONAL';
 446         }
 447
 448         unless ( $success ) {
 449           debug -> warn( level => 1,
 450                          message => $errmess." 2 $!" );
 451           $self -> parsing_error( message => $errmess." 2 $!" );
 452         } else {
 453           $self -> {'lstfile_pos'} = $start_pos;
 454         }
 455       }
 456 end _read_block_structures
 457
 458 # }}} _read_block_structures
 459
 460 # {{{ _read_steps_allowed
 461 start _read_steps_allowed
 462 # These statements are optional. Return to start_pos if not found
 463     my $start_pos = $self -> {'lstfile_pos'};
 464 my $est_allowed  = 1;
 465 my $cov_allowed  = 1;
 466 my $nonp_allowed  = 1;
 467 my $tables_allowed  = 1; # I am not sure that this is actually something which can be marked as not valid
 468
 469 while( $_ = @{$self -> {'lstfile'}}[ $start_pos++ ] ) {
 470   if ( /^ PROBLEM.*SUBPROBLEM/ or /^ PROBLEM NO\.:\s+\d/ or
 471        /^0ITERATION NO./ or /^0MINIMIZATION/) {
 472     # This is ok, we should end up here
 473     last;
 474   }
 475
 476   if( /0ESTIMATION STEP NOT ALLOWED/ ) {
 477     $est_allowed = 0;
 478   }
 479
 480   if( /0COVARIANCE STEP NOT ALLOWED/ ) {
 481     $cov_allowed = 0;
 482   }
 483
 484   if( /0NONPARAMETRIC STEP NOT ALLOWED/ ) {
 485     $nonp_allowed = 0;
 486   }
 487
 488   if( /0TABLES STEP NOT ALLOWED/ ) { # As indicated above, this is unsure but this coding should not harm
 489     $tables_allowed = 0;
 490   }
 491
 492   if( /0INPUT MODEL SPECIFICATION FILE GENERATED FROM A NON-TERMINATING ESTIMATION STEP/ ) {
 493     if( @{$self -> {'lstfile'}}[ $start_pos ] =~ / BUT CONTINUING ESTIMATION STEP NOT IMPLEMENTED/ ) {
 494       # If this happens, NONMEM aborts so we are finished reading
 495       $self -> finished_parsing(1);
 496     }
 497   }
 498
 499   if( /0MODEL SPECIFICATION FILE IS EMPTY/ ) {
 500     # If this happens, NONMEM aborts so we are finished reading
 501     $self -> finished_parsing(1);
 502   }
 503 }
 504
 505 unless( ( $self -> estimation_step_initiated()    * $est_allowed ) or
 506         ( $self -> covariance_step_run()    * $cov_allowed ) or
 507         ( $self -> nonparametric_step_run() * $nonp_allowed ) or
 508         ( $self -> tables_step_run() * $tables_allowed ) ) {
 509   # If this happens, NONMEM aborts so we are finished reading
 510   $self -> finished_parsing(1);
 511 }
 512 end _read_steps_allowed
 513 # }}} _read_steps_allowed
 514
 515 # {{{ _read_tablesstep
 516 start _read_tablesstep
 517 # The tables step is optional
 518     my $start_pos = $self -> {'lstfile_pos'};
 519 my $success  = 0;
 520
 521 while( $_ = @{$self -> {'lstfile'}}[ $start_pos++ ] ) {
 522   if ( /^1\s*$/ ) {
 523     # This is ok, the tables step was not used.
 524     $start_pos -= 2;
 525     $success = 1;
 526     last;
 527   }
 528   if( /^ PROBLEM NO\.:\s+\d/ or
 529       /^0MINIMIZATION/ ) {
 530     # This should not happen, raise error
 531     my $errmess = "Found $_ while searching for the (optional) ".
 532         "tables step indicator\n";
 533     debug -> warn( level => 1,
 534                    message => $errmess."$!" );
 535     $self -> parsing_error( message => $errmess."$!" );
 536     return;
 537   }
 538
 539   if ( ($start_pos + 1) == scalar @{$self -> {'lstfile'}} ) {
 540     #EOF This should not happen, raise error
 541     my $errmess = "Reached end of file while  searching for the ".
 542         "(optional) tables step indicator\n";
 543     debug -> warn( level => 1,
 544                    message => $errmess."$!" );
 545     $self -> parsing_error( message => $errmess."$!" );
 546     return;
 547   }
 548
 549   if(/^0TABLES STEP OMITTED:\s*\b(.*)\b/) {
 550     $self -> {'tables_step_run'} = 0 if $1 eq 'YES';
 551     $self -> {'tables_step_run'} = 1 if $1 eq 'NO';
 552     $success = 1;
 553     last;
 554   }
 555 }
 556
 557 unless ( $success ) {
 558   debug -> warn( level   => 2,
 559                  message => "rewinding to first position..." );
 560 } else {
 561   $self -> {'lstfile_pos'} = $start_pos;
 562 }
 563 end _read_tablesstep
 564 # }}} _read_tablesstep
 565
 566 # {{{ _read_prior
 567
 568 start _read_prior
 569 {
 570   my $start_pos = $self -> {'lstfile_pos'};
 571   my $success  = 0;
 572   while( $_ = @{$self -> {'lstfile'}}[ $start_pos++ ] ) {
 573 #    if ( /1DOUBLE PRECISION PREDPP/ ) { This is not always printed
 574     if ( /^1\s*$/ or
 575        /0SEARCH WITH ESTIMATION STEP WILL NOT PROCEED/ ) {
 576       # This is ok, no user defined prior was used.
 577       $start_pos -= 2;
 578       $success = 1;
 579       last;
 580     }
 581     if( /^ PROBLEM NO\.:\s+\d/ or
 582         /^0MINIMIZATION/ ) {
 583       # This should not happen, raise error
 584       my $errmess = "Found $_ while searching for the (optional) ".
 585           "user defined prior indicator\n";
 586       debug -> warn( level => 1,
 587                      message => $errmess."$!" );
 588       $self -> parsing_error( message => $errmess."$!" );
 589       return;
 590     }
 591
 592     if ( ($start_pos + 1) == scalar @{$self -> {'lstfile'}} ) {
 593       #EOF This should not happen, raise error
 594       my $errmess = "Reached end of file while  searching for the ".
 595           "(optional) user defined prior indicator\n";
 596       debug -> warn( level => 1,
 597                      message => $errmess."$!" );
 598       $self -> parsing_error( message => $errmess."$!" );
 599       return;
 600     }
 601
 602     if(/^ PRIOR SUBROUTINE USER-SUPPLIED/){
 603       $self -> {'user_defined_prior'} = 1;
 604       $success = 1;
 605       last;
 606     }
 607   }
 608
 609   unless ( $success ) {
 610     debug -> warn( level   => 2,
 611                    message => "rewinding to first position..." );
 612   } else {
 613     $self -> {'lstfile_pos'} = $start_pos;
 614   }
 615
 616 }
 617 end _read_prior
 618
 619 # }}}
 620
 621 # {{{ _read_nonpstep
 622 start _read_nonpstep
 623 # The nonparametric step is optional
 624     my $start_pos = $self -> {'lstfile_pos'};
 625 my $success  = 0;
 626
 627 while( $_ = @{$self -> {'lstfile'}}[ $start_pos++ ] ) {
 628   if ( /^0COVARIANCE STEP OMITTED/ or
 629        /0TABLES STEP OMITTED/ or
 630        /1DOUBLE PRECISION PREDPP/ or
 631        /0SEARCH WITH ESTIMATION STEP WILL NOT PROCEED/ or
 632        /^1/ or
 633        /^0MINIMIZATION/ or
 634        /^ PROBLEM NO\.:\s+\d/ ) {
 635     # This is ok, the nonp step was not used.
 636     last;
 637   }
 638
 639 #  if( /^ PROBLEM NO\.:\s+\d/ or
 640 #      /^0MINIMIZATION/ ) {
 641     # This should not happen, raise error
 642 #    my $errmess = "Found $_ while searching for the (optional) ".
 643 #       "nonparametric step indicator\n";
 644 #    debug -> warn( level => 1,
 645 #                  message => $errmess."$!" );
 646 #    $self -> parsing_error( message => $errmess."$!" );
 647 #    return;
 648 #  }
 649
 650   if ( ($start_pos + 1) == scalar @{$self -> {'lstfile'}} ) {
 651     #EOF This should not happen, raise error
 652     my $errmess = "Reached end of file while  searching for the ".
 653         "(optional) nonparametric step indicator\n";
 654     debug -> warn( level => 1,
 655                    message => $errmess."$!" );
 656     $self -> parsing_error( message => $errmess."$!" );
 657     return;
 658   }
 659
 660   if(/^0NONPARAMETRIC STEP OMITTED:\s*\b(.*)\b/) {
 661     $self -> {'nonparametric_step_run'} = 0 if $1 eq 'YES';
 662     $self -> {'nonparametric_step_run'} = 1 if $1 eq 'NO';
 663     $success = 1;
 664     last;
 665   }
 666 }
 667
 668 unless ( $success ) {
 669   debug -> warn( level   => 2,
 670                  message => "rewinding to first position..." );
 671 } else {
 672   $self -> {'lstfile_pos'} = $start_pos;
 673 }
 674 end _read_nonpstep
 675 # }}} _read_nonpstep
 676
 677 # {{{ _read_eststep
 678 start _read_eststep
 679 # A combination of simulation and estimation step indications should always be found, raise error otherwise
 680     my $start_pos = $self -> {'lstfile_pos'};
 681 my $success  = 0;
 682
 683 while( $_ = @{$self -> {'lstfile'}}[ $start_pos++ ] ) {
 684   if ( /^0COVARIANCE STEP OMITTED/ or
 685        /^0NONPARAMETRIC STEP OMITTED/ or
 686        /^0TABLES STEP OMITTED/ or
 687        /^1/ or
 688        /^0MINIMIZATION/ or
 689        /^ PROBLEM NO\.:\s+\d/ ) {
 690     unless( $success ) {
 691       # This should not happen, raise error
 692       my $errmess = "Found $_ while searching for the simulation/estimation step indicators\n";
 693       debug -> warn( level => 1,
 694                      message => $errmess."$!" );
 695       $self -> parsing_error( message => $errmess."$!" );
 696     }
 697     return;
 698   }
 699
 700   if ( ($start_pos + 1) == scalar @{$self -> {'lstfile'}} ) {
 701     #EOF This should not happen, raise error
 702     my $errmess = "Reached end of file while searching for the simulation/estimation step indicators\n";
 703     debug -> warn( level => 1,
 704                    message => $errmess."$!" );
 705     $self -> parsing_error( message => $errmess."$!" );
 706     return;
 707   }
 708
 709   if(/^ PRIOR SUBROUTINE USER-SUPPLIED/){
 710     $success = 1;
 711   }
 712
 713   if(/^0ESTIMATION STEP OMITTED:\s*\b(.*)\b/) {
 714     $self -> estimation_step_initiated(1);
 715     $self -> estimation_step_run(0) if $1 eq 'YES';
 716     $self -> estimation_step_run(1) if $1 eq 'NO';
 717     $success = 1;
 718   }
 719   if(/^0SIMULATION STEP OMITTED:\s*\b(.*)\b/) {
 720     $self -> simulation_step_run(0) if $1 eq 'YES';
 721     $self -> simulation_step_run(1) if $1 eq 'NO';
 722     $success = 1;
 723   }
 724 }
 725
 726 unless ( $success ) {
 727   debug -> warn( level   => 2,
 728                  message => "rewinding to first position..." );
 729 } else {
 730   $self -> {'lstfile_pos'} = $start_pos;
 731 }
 732 end _read_eststep
 733 # }}} _read_eststep
 734
 735 # {{{ _read_covstep
 736 start _read_covstep
 737       {
 738         my $start_pos = $self -> {'lstfile_pos'};
 739         my $success  = 0;
 740
 741         while( $_ = @{$self -> {'lstfile'}}[ $start_pos++ ] ) {
 742
 743           if(/0COVARIANCE STEP OMITTED:\s*\b(.*)\b/) {
 744             $self -> {'covariance_step_run'} = 0 if $1 eq 'YES';
 745             $self -> {'covariance_step_run'} = 1 if $1 eq 'NO';
 746             $success = 1;
 747             last;
 748           }
 749           if ( /^ PROBLEM.*SUBPROBLEM/ or /^ PROBLEM NO\.:\s+\d/ or
 750                /^0ITERATION NO./ or /^0MINIMIZATION/) {
 751             # This is ok, we should end up here
 752             last;
 753           }
 754         }
 755
 756         unless ( $success ) {
 757           debug -> warn( level   => 2,
 758                          message => "rewinding to first position..." );
 759         } else {
 760           $self -> {'lstfile_pos'} = $start_pos;
 761         }
 762       }
 763 end _read_covstep
 764 # }}} _read_covstep
 765
 766 # {{{ _read_inits
 767
 768 start _read_inits
 769 # The inits should always be present if no model specification file input is used
 770 # Raise parsing error if not found
 771       {
 772         my $errmess = "Error in reading the initial estimates!\n";
 773         my $start_pos = $self -> {'lstfile_pos'};
 774         my ( @thetas, @omegas, @sigmas );
 775         my $thetarea = 0;
 776         my $omegarea = 0;
 777         my $sigmarea = 0;
 778         my $success  = 0;
 779         my $tmp = $start_pos;
 780
 781         # Look for a general statement of fixed sigmas and omegas
 782         my $all_sigmas_fixed = 0;
 783         my $all_omegas_fixed = 0;
 784         while( $_ = @{$self -> {'lstfile'}}[ $tmp++ ] ) {
 785           if ( /^0SIGMA CONSTRAINED TO BE THIS INITIAL ESTIMATE/ ) {
 786             $all_sigmas_fixed = 1;
 787           }
 788           if ( /^0OMEGA CONSTRAINED TO BE THIS INITIAL ESTIMATE/ ) {
 789             $all_omegas_fixed = 1;
 790           }
 791           if ( /^0ESTIMATION STEP OMITTED/ or
 792                /^0SIMULATION STEP OMITTED/ ) {
 793             last;
 794           }
 795           if ( /^ INITIAL ESTIMATE OF OMEGA HAS A NONZERO BLOCK WHICH IS NUMERICALLY NOT POSITIVE DEFINITE/ ) {
 796             $self -> finished_parsing(1);
 797             $self -> pre_run_errors($_);
 798             return;
 799           }
 800           if ( ($start_pos + 1) == scalar @{$self -> {'lstfile'}} ) {
 801             #EOF This should not happen, raise error
 802             my $errmess = "Reached end of file while parsing initial estimates\n";
 803             debug -> warn( level => 1,
 804                            message => $errmess."$!" );
 805             $self -> parsing_error( message => $errmess."$!" );
 806             return;
 807           }
 808
 809         }
 810
 811         while( $_ = @{$self -> {'lstfile'}}[ $start_pos++ ] ) {
 812
 813           if ( /^0MODEL SPECIFICATION FILE INPUT/ ) {
 814             # We can't find any initial estimates but that's ok
 815             $self -> msfi_used(1);
 816             $success = 1;
 817             $start_pos--;
 818             last;
 819           }
 820
 821           if ( /^0INITIAL ESTIMATE OF THETA/ ) {
 822             # If we find this we must find other stuff too. Set
 823             # success = 0 and change this if we find the rest. Nope,
 824             # not true. $THETA can be found alone using the LIKE
 825             # option in the $EST record.
 826             $thetarea = 1;
 827           }
 828
 829           if ( /^0ESTIMATION STEP OMITTED/ or
 830                /^0SIMULATION STEP OMITTED/ ) {
 831             # We want to find this if we are currently reading the omega or sigma inits
 832             $success = 1 if ( $thetarea or $sigmarea or $omegarea);
 833             $start_pos --;
 834             last;
 835           }
 836
 837           if ( ($start_pos + 1) == scalar @{$self -> {'lstfile'}} ) {
 838             #EOF This should not happen, raise error
 839             my $errmess = "Reached end of file while parsing the initial estimates\n";
 840             debug -> warn( level => 1,
 841                            message => $errmess."$!" );
 842             $self -> parsing_error( message => $errmess."$!" );
 843             return;
 844           }
 845           if ( $thetarea and /^\s*-?\d*\.\d*/ ) {
 846             my @T = split(' ',$_);
 847             push(@{$self -> {'initthetas'}},eval($T[1]));
 848             push(@{$self -> {'lower_theta_bounds'}},eval($T[0]));
 849             push(@{$self -> {'upper_theta_bounds'}},eval($T[2]));
 850             if ( $T[0] == $T[1] and $T[0] == $T[2] ) {
 851               push(@{$self -> {'fixedthetas'}},1);
 852               push(@{$self -> {'estimated_thetas'}},0);
 853             } else {
 854               push(@{$self -> {'fixedthetas'}},0);
 855               push(@{$self -> {'estimated_thetas'}},1);
 856             }
 857           }
 858           if ( /^0INITIAL ESTIMATE OF OMEGA:/ ) {
 859             $thetarea = 0;
 860             $omegarea = 1;
 861             $success = 1;
 862             if ( defined $self -> {'omega_block_sets'} and
 863                  scalar keys %{$self -> {'omega_block_sets'}} > 0 ) {
 864               # We currently assume that this part is atomic. No parser checks are made
 865               $start_pos++;
 866               my %om_bl = %{$self -> {'omega_block_sets'}};
 867               my @blocks = sort {$a <=> $b} keys %om_bl;
 868               foreach my $block ( @blocks ) {
 869                 my @fix_row = split(' ', $self -> {'lstfile'}[ $start_pos++ ]);
 870                 my $fix = $fix_row[1] eq 'YES' ? 1 : 0;
 871                 if( $all_omegas_fixed ) {
 872                   $fix = 1;
 873                 }
 874                 for ( my $size = 1; $size <= $om_bl{$block}{'size'}; $size++ ) {
 875                   for ( my $row = $start_pos ; $row < $start_pos + $om_bl{$block}{'dimension'}; $row++ ) {
 876                     my @init_row = split(' ', $self -> {'lstfile'}[ $row ]);
 877                     foreach my $init ( @init_row ) {
 878                       push( @{$self -> {'fixedomegas'}}, $fix );
 879                       push( @{$self -> {'estimated_omegas'}}, (not $fix and $size == 1) ? 1 : 0 );
 880                       push(@{$self -> {'initomegas'}}, eval($init) );
 881                       push(@{$self -> {'lower_omega_bounds'}},0);
 882                       push(@{$self -> {'upper_omega_bounds'}},1000000);
 883                     }
 884                   }
 885                 }
 886                 $start_pos += $om_bl{$block}{'dimension'};
 887               }
 888             } else {
 889               my $om_row = 1;
 890               while( ($start_pos + 1) < scalar @{$self -> {'lstfile'}} ) {
 891                 if( $self -> {'lstfile'}[ $start_pos ] =~ /^0INITIAL ESTIMATE OF SIGMA/ or
 892                     $self -> {'lstfile'}[ $start_pos ] =~ /^0SIMULATION STEP OMITTED/ or
 893                     $self -> {'lstfile'}[ $start_pos ] =~ /^0ESTIMATION STEP OMITTED/ or
 894                     $self -> {'lstfile'}[ $start_pos ] =~ /^0OMEGA CONSTRAINED TO BE THIS INITIAL ESTIMATE/ ) {
 895                   $start_pos--;
 896                   last;
 897                 }
 898
 899                 # After ten rows of omegas NONMEM starts wrapping
 900                 # lines. We then need to skip the first part of the
 901                 # wrapped lines. This nice littel formula calculates
 902                 # how many lines to skip.
 903
 904                 my $skip_lines = ($om_row - $om_row % 10)/10;
 905
 906                 $start_pos += $skip_lines if( $om_row > 10 );
 907
 908                 my @init_row = split(' ', $self -> {'lstfile'}[ $start_pos++ ]);
 909                 if( not $init_row[$#init_row] =~ /[0-9]?\.[0-9]{4}E[+-][0-9]{2}/ ) {
 910                   my $errmess = "Error parsing omega initial estimates, found non-number:\n".
 911                       $self -> {'lstfile'}[ $start_pos-1 ]."\n";
 912                   debug -> warn( level => 1,
 913                                  message => $errmess."$!" );
 914                   $self -> parsing_error( message => $errmess."$!" );
 915                   return;
 916                 }
 917
 918                 my $init = eval($init_row[$#init_row]);
 919                 unless( $init == 0 ) {
 920                   push( @{$self -> {'fixedomegas'}}, $all_omegas_fixed ? 1 : 0 );
 921                   push( @{$self -> {'initomegas'}}, eval($init) );
 922                 }
 923                 push( @{$self -> {'estimated_omegas'}}, $all_omegas_fixed ? 0 : 1 );
 924                 push(@{$self -> {'lower_omega_bounds'}},0);
 925                 push(@{$self -> {'upper_omega_bounds'}},1000000);
 926                 $om_row++;
 927               }
 928             }
 929           }
 930           if ( /^0INITIAL ESTIMATE OF SIGMA:/ ) {
 931             $thetarea = 0;
 932             $omegarea = 0;
 933             $sigmarea = 1;
 934             if ( defined $self -> {'sigma_block_sets'} and
 935                  scalar keys %{$self -> {'sigma_block_sets'}} > 0 ) {
 936               # We currently assume that this part is atomic. No parser checks are made
 937               $start_pos++;
 938               my %si_bl = %{$self -> {'sigma_block_sets'}};
 939               my @blocks = sort {$a <=> $b} keys %si_bl;
 940               foreach my $block ( @blocks ) {
 941                 my @fix_row = split(' ', $self -> {'lstfile'}[ $start_pos++ ]);
 942                 my $fix = $fix_row[1] eq 'YES' ? 1 : 0;
 943                 if( $all_sigmas_fixed ) {
 944                   $fix = 1;
 945                 }
 946                 for ( my $size = 1; $size <= $si_bl{$block}{'size'}; $size++ ) {
 947                   for ( my $row = $start_pos ; $row < $start_pos + $si_bl{$block}{'dimension'}; $row++ ) {
 948                     my @init_row = split(' ', $self -> {'lstfile'}[ $row ]);
 949                     foreach my $init ( @init_row ) {
 950                       push( @{$self -> {'fixedsigmas'}}, $fix );
 951                       push( @{$self -> {'estimated_sigmas'}}, (not $fix and $size == 1) ? 1 : 0 );
 952                       push(@{$self -> {'initsigmas'}}, eval($init) );
 953                       push(@{$self -> {'lower_sigma_bounds'}},0);
 954                       push(@{$self -> {'upper_sigma_bounds'}},1000000);
 955                     }
 956                   }
 957                 }
 958                 $start_pos += $si_bl{$block}{'dimension'};
 959               }
 960             } else {
 961               my $sm_row = 1;
 962               while( ($start_pos + 1) < scalar @{$self -> {'lstfile'}} ) {
 963                 if( $self -> {'lstfile'}[ $start_pos ] =~ /^0SIMULATION STEP OMITTED/ or
 964                     $self -> {'lstfile'}[ $start_pos ] =~ /^0ESTIMATION STEP OMITTED/ or
 965                     $self -> {'lstfile'}[ $start_pos ] =~ /^0SIGMA CONSTRAINED TO BE THIS INITIAL ESTIMATE/ ) {
 966                   $start_pos--;
 967                   last;
 968                 }
 969
 970                 # After ten rows of sigmas NONMEM starts wrapping
 971                 # lines. We then need to skip the first part of the
 972                 # wrapped lines. This nice littel formula calculates
 973                 # how many lines to skip.
 974
 975                 my $skip_lines = ($sm_row - $sm_row % 10)/10;
 976
 977                 $start_pos += $skip_lines if( $sm_row > 10 );
 978
 979                 my @init_row = split(' ', $self -> {'lstfile'}[ $start_pos++ ]);
 980                 if( not $init_row[$#init_row] =~ /[0-9]?\.[0-9]{4}E[+-][0-9]{2}/ ) {
 981                   my $errmess = "Error parsing sigma initial estimates, found non-number\n".
 982                       $self -> {'lstfile'}[ $start_pos-1 ];
 983                   debug -> warn( level => 1,
 984                                  message => $errmess."$!" );
 985                   $self -> parsing_error( message => $errmess."$!" );
 986                   return;
 987                 }
 988
 989                 my $init = eval($init_row[$#init_row]);
 990                 unless( $init == 0 ) {
 991                   push( @{$self -> {'fixedsigmas'}}, $all_sigmas_fixed ? 1 : 0 );
 992                   push( @{$self -> {'initsigmas'}}, eval($init) );
 993                 }
 994                 push( @{$self -> {'estimated_sigmas'}},  $all_sigmas_fixed ? 0 : 1 );
 995                 push(@{$self -> {'lower_sigma_bounds'}},0);
 996                 push(@{$self -> {'upper_sigma_bounds'}},1000000);
 997                 $sm_row++;
 998               }
 999             }
1000           }
1001 #         if ( /^0MINIMIZATION/ ) {
1002 #           last;
1003 #         }
1004         }
1005
1006         unless ( $success ) {
1007           debug -> warn( level   => 2,
1008                          message => "rewinding to first position..." );
1009         } else {
1010 # Keep this code
1011 #         if ( $PsN::config -> {'_'} -> {'use_database'} and
1012 #              $self -> {'register_in_database'} ) {
1013 #           my $dbh = DBI -> connect("DBI:mysql:host=".$PsN::config -> {'_'} -> {'database_server'}.
1014 #                              ";databse=".$PsN::config -> {'_'} -> {'project'},
1015 #                                    $PsN::config -> {'_'} -> {'user'},
1016 #                               $PsN::config -> {'_'} -> {'password'},
1017 #                                    {'RaiseError' => 1});
1018 #           my $sth;
1019 #           my @mod_str = ('','');
1020 #           if ( defined $self -> {'model_id'} ) {
1021 #             @mod_str = ('model_id,',"$self->{'model_id'},");
1022 #           }
1023 #           foreach my $param ( 'theta', 'omega', 'sigma' ) {
1024 #             foreach my $par_str ( @{$self -> {'init'.$param.'s'}} ) {
1025 #               $sth = $dbh -> prepare("INSERT INTO ".$PsN::config -> {'_'} -> {'project'}.
1026 #                              ".estimate ".
1027 #                                      "(subproblem_id,problem_id,output_id,".
1028 #                                      $mod_str[0].
1029 #                                      "type,value,init) ".
1030 #                                      "VALUES ( 1 ,".
1031 #                                      "'$self->{'problem_id'}' ,".
1032 #                                      "'$self->{'output_id'}' ,".
1033 #                                      $mod_str[1].
1034 #                                      "'$param','$par_str','1')");
1035 #               $sth -> execute;
1036 #               push( @{$self -> {'estimate_ids'}}, $sth->{'mysql_insertid'} );
1037 #             }
1038 #           }
1039 #           $sth -> finish;
1040
1041 #           $dbh -> disconnect;
1042 #         }
1043
1044           $self -> {'lstfile_pos'} = $start_pos;
1045         }
1046       }
1047 end _read_inits
1048
1049 # }}} _read_inits
1050
1051 # {{{ access_any
1052
1053 start access_any
1054       {
1055         unless( $#subproblems > 0 ){
1056           debug -> warn( level => 2,
1057                            message => "subproblems undefined, using all." );
1058           if( defined $self -> {'subproblems'} ) {
1059             @subproblems = (1 .. scalar @{$self -> {'subproblems'}});
1060           } else {
1061             debug -> warn( level   => 1,
1062                            message => "No subproblems defined in this problem." );
1063             @subproblems = ();
1064           }
1065         }
1066
1067
1068         my @own_subproblems = defined $self -> {'subproblems'} ? @{$self -> {'subproblems'}} : ();
1069         foreach my $i ( @subproblems ) {
1070           if ( defined $own_subproblems[$i-1] ) {
1071             debug -> warn( level   => 2,
1072                            message => "subproblems: $i" );
1073             debug -> warn( level   => 2,
1074                            message => "Attribute: ".$own_subproblems[$i-1] -> $attribute );
1075             my $meth_ret = $own_subproblems[$i-1] -> $attribute;
1076
1077             # Test if the returned value is an array (with hashes we
1078             # can't allow selection based on parameter numbers, since
1079             # a hash is not ordered)
1080             if ( ref ( $meth_ret ) eq 'ARRAY' ) {
1081               #my @subprob_attr = @{$own_subproblems[$i-1] -> $attribute};
1082               my @subprob_attr = @{$meth_ret};
1083               if ( scalar @parameter_numbers > 0 ) {
1084                 my @tmp_arr = ();
1085                 foreach my $num ( @parameter_numbers ) {
1086                   if ( $num > 0 and $num <= scalar @subprob_attr ) {
1087                     push( @tmp_arr, $subprob_attr[$num-1] );
1088                   } else {
1089                     debug -> die( message => "( $attribute ): no such parameter number $num!".
1090                                   "(".scalar @subprob_attr." exists)" );
1091                   }
1092                 }
1093                 @subprob_attr = @tmp_arr;
1094               }
1095               push( @return_value, \@subprob_attr );
1096             } else {
1097 #             push( @return_value, $meth_ret ) if defined $meth_ret;
1098               push( @return_value, $meth_ret );
1099             }
1100           } else {
1101             debug -> die( message => "No such subproblem ".($i-1) );
1102           }
1103         }
1104         # Check the return_value to see if we have empty arrays
1105         if ( $#return_value == 0  and ref ($return_value[0]) eq 'ARRAY' and scalar @{$return_value[0]} < 1 ) {
1106            @return_value = ();
1107         }
1108       }
1109 end access_any
1110
1111 # }}} access_any
1112
1113 # {{{ _set_labels
1114
1115 start _set_labels
1116       {
1117         if ( defined $self -> {'subproblems' } ) {
1118           foreach my $type ( ('theta','omega','sigma') ) {
1119             my $first_sub = @{$self -> {'subproblems'}}[0];
1120             my $accessor = $type eq 'theta' ? $type.'s' : 'raw_'.$type.'s';
1121             if( defined $first_sub -> $accessor ) {
1122               my @param = @{$first_sub -> $accessor};
1123               if ( scalar @param > 0 ) {
1124                 my ( @names, @indexes );
1125                 my ($j,$ndiags);
1126                 foreach $j (1..scalar @param) {
1127                   if ( $type eq 'theta' ) {
1128                     push( @names, "TH$j" );
1129                   } else {
1130                     if ( $first_sub -> _isdiagonal('index' => $j) ) {
1131                       push @names, uc(substr($type,0,2)).++$ndiags;
1132                       if ( $type eq 'omega' ) {
1133                         push ( @{$self -> {'omega_indexes'}}, [$ndiags, $ndiags] );
1134                       } else {
1135                         push ( @{$self -> {'sigma_indexes'}}, [$ndiags, $ndiags] );
1136                       }
1137                       next;
1138                     } elsif ($param[$j-1] !=0) {
1139                       @indexes = $first_sub -> _rowcolind( index => $j);
1140                       push @names,uc(substr($type,0,2)).$indexes[0].'_'.$indexes[1];
1141                       if ( $type eq 'omega' ) {
1142                         push ( @{$self -> {'omega_indexes'}}, [$indexes[0], $indexes[1]] );
1143                       } else {
1144                         push ( @{$self -> {'sigma_indexes'}}, [$indexes[0], $indexes[1]] );
1145                       }
1146                     }
1147                   }
1148                 }
1149                 $self ->{$type.'names'} = \@names;
1150               }
1151             }
1152           }
1153         }
1154       }
1155 end _set_labels
1156
1157 # }}} _set_labels