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