lib/model_subs.pm

   1 # TODO: All: 2004-09-06 Fix absolute paths for data and output files. (under both
   2 # windows and unix)
   3
   4 # {{{ Include
   5
   6 start include statements
   7 # A Perl module for parsing and manipulating NONMEM model files
   8
   9 my $VERSION = '1.00';
  10 use Digest::MD5 'md5_hex';
  11 use Cwd;
  12 use File::Copy 'cp';
  13 use Config;
  14 use OSspecific;
  15 use Storable;
  16 use Data::Dumper;
  17 use POSIX qw(ceil floor);
  18 end include statements
  19
  20 # }}} include statements
  21
  22 # {{{ description, synopsis and see_also
  23
  24 # No method, just documentation
  25 start description
  26     # The model class is built around the NONMEM model file. This is an
  27     # ordinary ASCII text file that, except for the data, holds all
  28     # information needed for fitting a non-linear mixed effect model
  29     # using NONMEM. Typically, a model file contains specifications
  30     # for a pharmacokinetic and/or a pharmacodynamic model, initial
  31     # estimates of model parameters, boundaries for model parameters
  32     # as well as details about the data location and format.
  33     #
  34     # =begin html
  35     #
  36     # Note that the functionality for actually running NONMEM has been
  37     # moved to <a href="tool/modelfit.html">tool::modelfit</a>.
  38     #
  39     # =end html
  40     #
  41     # =begin man
  42     #
  43     # Note that the functionality for actually running NONMEM has been
  44     # moved to I<tool::modelfit>.
  45     #
  46     # =end man
  47 end description
  48
  49 start synopsis
  50     #   use model;
  51     #
  52     #   my $mod_obj = model -> new ( filename => 'run1.mod' );
  53     #
  54     #   $mod_obj -> datafiles ( new_names => ['test040314.dta'] );
  55     #
  56     #   $mod_obj -> initial_values ( parameter_type    => 'theta',
  57     #                                parameter_numbers => [[1,3]],
  58     #                                new_values        => [[1.2,34]] );
  59 end synopsis
  60
  61 start see_also
  62     # =begin html
  63     #
  64     # <a HREF="data.html">data</a>, <a HREF="output.html">output</a>
  65     # <a HREF="tool/modelfit.html">tool::modelfit</a>,
  66     # <a HREF="tool.html">tool</a>
  67     #
  68     # =end html
  69     #
  70     # =begin man
  71     #
  72     # data, output, tool::modelfit, tool
  73     #
  74     # =end man
  75 end see_also
  76
  77 # }}}
  78
  79 # {{{ accessor_text
  80
  81 start accessor_text
  82         #
  83 end accessor_text
  84
  85 # }}}
  86
  87
  88 # {{{ new
  89
  90 start new
  91     {
  92         # Usage:
  93         #
  94         #   $model = model -> new( filename => 'run1.mod' )
  95         #
  96         # This is the simplest and most common way to create a model
  97         # object and it requires a file on disk.
  98         #
  99         #   $model = model -> new( filename => 'run1.mod',
 100         #                          target   => 'mem' )
 101         #
 102         # If the target parameter is set to anything other than I<mem>
 103         # the output object (with file name given by the model
 104         # attribute I<outputfile>) and the data objects (identified by
 105         # the data file names in the $DATA NONMEM model file section)
 106         # will be initialized but will contain no information from
 107         # their files. If information from them are requiered later
 108         # on, they are read and parsed and the appropriate attributes
 109         # of the data and output objects are set.
 110         #
 111         # =begin man
 112         #
 113         # See I<data> and I<output> for details.
 114         #
 115         # =end man
 116         #
 117         # =begin html
 118         #
 119         # See <a href="data.html">data</a> and <a href="output.html">
 120         # output</a> for details.
 121         #
 122         # =end html
 123
 124         if ( defined $parm{'problems'} ) {
 125             $this -> {'problems'} = $parm{'problems'};
 126         } else {
 127             ($this -> {'directory'}, $this -> {'filename'}) =
 128                 OSspecific::absolute_path( $this -> {'directory'}, $this -> {'filename'} );
 129             $this -> _read_problems;
 130             $this -> {'synced'} = 1;
 131         }
 132
 133         if ( defined $parm{'active_problems'} ) {
 134             $this -> {'active_problems'} = $parm{'active_problems'};
 135         } elsif ( defined $this -> {'problems'} ) {
 136             my @active = ();
 137             for ( @{$this -> {'problems'}} ) {
 138                 push( @active, 1 );
 139             }
 140             $this -> {'active_problems'} = \@active;
 141         }
 142
 143         if ( defined $this -> {'extra_data_files'} ){
 144           for( my $i; $i < scalar @{$this -> {'extra_data_files'}}; $i++ ){
 145             my ( $dir, $file ) = OSspecific::absolute_path( $this -> {'directory'}, $this -> {'extra_data_files'} -> [$i]);
 146             $this -> {'extra_data_files'} -> [$i] = $dir . $file;
 147           }
 148         }
 149
 150         my $subroutine_files = $this -> subroutine_files;
 151         if( defined $subroutine_files and scalar @{$subroutine_files} > 0 ){
 152           push( @{$this -> {'extra_files'}}, @{$subroutine_files} );
 153         }
 154
 155         if ( defined $this -> {'extra_files'} ){
 156           for( my $i; $i < scalar @{$this -> {'extra_files'}}; $i++ ){
 157             my ( $dir, $file ) = OSspecific::absolute_path( $this -> {'directory'}, $this -> {'extra_files'} -> [$i]);
 158             $this -> {'extra_files'} -> [$i] = $dir . $file;
 159           }
 160         }
 161
 162         # Read datafiles, if any.
 163         unless( defined $this -> {'datas'} and not $this -> {'quick_reload'} ){
 164             my @idcolumns = @{$this -> idcolumns};
 165             my @datafiles = @{$this -> datafiles('absolute_path' => 1)};
 166 #           my @datafiles = @{$this -> datafiles('absolute_path' => 0)};
 167             for ( my $i = 0; $i <= $#datafiles; $i++ ) {
 168               my $datafile = $datafiles[$i];
 169               my $idcolumn = $idcolumns[$i];
 170               my ( $cont_column, $wrap_column ) = $this -> {'problems'} -> [$i] -> cont_wrap_columns;
 171               my $ignoresign = defined $this -> ignoresigns ? $this -> ignoresigns -> [$i] : undef;
 172               my @model_header = @{$this -> {'problems'} -> [$i] -> header};
 173               if ( defined $idcolumn ) {
 174                 push ( @{$this -> {'datas'}}, data ->
 175                        new( idcolumn             => $idcolumn,
 176                             filename             => $datafile,
 177                             cont_column          => $cont_column,
 178                             wrap_column          => $wrap_column,
 179                             #model_header         => \@model_header,
 180                             ignoresign           => $ignoresign,
 181                             directory            => $this -> {'directory'},
 182                             ignore_missing_files => $this -> {'ignore_missing_files'} ||
 183                             $this -> {'ignore_missing_data'},
 184                             target               => $this -> {'target'}) );
 185               } else {
 186                 'debug' -> die( message => "Model -> new: Both idcolumn and datafile must ".
 187                                 "be specified to create a model object." );
 188               }
 189             }
 190         }
 191
 192         # Read outputfile, if any.
 193         if( ! defined $this -> {'outputs'} ) {
 194             unless( defined $this -> {'outputfile'} ){
 195                 ($this -> {'outputfile'} = $this -> {'filename'}) =~ s/\.mod$/.lst/;
 196             }
 197             push ( @{$this -> {'outputs'}}, output ->
 198                    new( filename             => $this -> {'outputfile'},
 199                         directory            => $this -> {'directory'},
 200                         ignore_missing_files =>
 201                         $this -> {'ignore_missing_files'} || $this -> {'ignore_missing_output_files'},
 202                         target               => $this -> {'target'},
 203                         model_id             => $this -> {'model_id'} ) );
 204         }
 205       }
 206 end new
 207
 208 # }}} new
 209
 210 # {{{ register_in_database
 211
 212 start register_in_database
 213   {
 214     if ( $PsN::config -> {'_'} -> {'use_database'} ) {
 215       # Backslashes messes up the sql syntax
 216       my $file_str = $self->{'filename'};
 217       my $dir_str = $self->{'directory'};
 218       $file_str =~ s/\\/\//g;
 219       $dir_str =~ s/\\/\//g;
 220
 221       # md5sum
 222       my $md5sum = md5_hex(OSspecific::slurp_file($self-> full_name ));
 223
 224       my $dbh = DBI -> connect("DBI:mysql:host=".$PsN::config -> {'_'} -> {'database_server'}.
 225                                ";databse=".$PsN::config -> {'_'} -> {'project'},
 226                                $PsN::config -> {'_'} -> {'user'},
 227                                $PsN::config -> {'_'} -> {'password'},
 228                                {'RaiseError' => 1});
 229
 230       my $sth;
 231
 232       my $select_arr = [];
 233
 234       if ( not $force ) {
 235         my $sth = $dbh -> prepare( "SELECT model_id FROM ".$PsN::config -> {'_'} -> {'project'}.
 236                                    ".model ".
 237                                    "WHERE filename = '$file_str' AND ".
 238                                    "directory = '$dir_str' AND ".
 239                                    "md5sum = '".$md5sum."'" );
 240         $sth -> execute or 'debug' -> die( message => $sth->errstr ) ;
 241
 242         $select_arr = $sth -> fetchall_arrayref;
 243       }
 244
 245       if ( scalar @{$select_arr} > 0 ) {
 246         'debug' -> warn( level   => 1,
 247                        message => "Found an old entry in the database matching the ".
 248                        "current model file" );
 249         if ( scalar @{$select_arr} > 1 ) {
 250           'debug' -> warn( level   => 1,
 251                          message => "Found more than one matching entry in database".
 252                          ", using the first" );
 253         }
 254         $self -> {'model_id'} = $select_arr->[0][0];
 255       } else {
 256         my ( $date_str, $time_str );
 257         if( $Config{osname} eq 'MSWin32' ){
 258           $date_str = `date /T`;
 259           $time_str = ' '.`time /T`;
 260         } else {
 261           # Assuming UNIX
 262           $date_str = `date`;
 263         }
 264         chomp($date_str);
 265         chomp($time_str);
 266         my $date_time = $date_str.$time_str;
 267         $sth = $dbh -> prepare("INSERT INTO ".$PsN::config -> {'_'} -> {'project'}.
 268                                ".model (filename,date,directory,md5sum) ".
 269                                "VALUES ('$file_str', '$date_time', '$dir_str','".
 270                                $md5sum."' )");
 271         $sth -> execute;
 272         $self -> {'model_id'} = $sth->{'mysql_insertid'};
 273       }
 274       $sth -> finish if ( defined $sth );
 275       $dbh -> disconnect;
 276     }
 277     $model_id = $self -> {'model_id'} # return the model_id;
 278   }
 279 end register_in_database
 280
 281 # }}} register_in_database
 282
 283 # {{{ shrinkage_stats
 284
 285 start shrinkage_stats
 286
 287 if ( $#problem_numbers > 0 and ref $enabled eq 'ARRAY' ){
 288   if ( $#problem_numbers != ( scalar @{$enabled} - 1 ) ) {
 289     'debug' -> die( message => "The number of problem_numbers ".($#problem_numbers+1).
 290                     "and enabled/disabled shrinkage_stats ".scalar @{$enabled}.
 291                     " do not match" );
 292   }
 293 }
 294 unless( $#problem_numbers > 0 ){
 295   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 296 }
 297 my @en_arr;
 298 if( ref \$enabled eq 'SCALAR' ) {
 299   for ( @problem_numbers ) {
 300     push( @en_arr, $enabled );
 301   }
 302 } elsif ( not ref $enabled eq 'ARRAY' ) {
 303   debug -> die( message => 'enabled must be a scalar or a reference to an array, '.
 304                 'not a reference to a '.ref($enabled).'.' );
 305 }
 306
 307 my @problems = @{$self -> {'problems'}};
 308 my $j = 0;
 309 foreach my $i ( @problem_numbers ) {
 310   if ( defined $problems[ $i-1 ] ) {
 311     if ( defined $en_arr[ $j ] ) {
 312       if( $en_arr[ $j ] ) {
 313         $problems[ $i-1 ] -> shrinkage_module -> enable;
 314       } else {
 315         $problems[ $i-1 ] -> shrinkage_module -> disable;
 316       }
 317 #       my $eta_file = $self -> filename.'_'.$i.'.etas';
 318 #       my $eps_file = $self -> filename.'_'.$i.'.wres';
 319 #       $problems[ $i-1 ] -> {'eta_shrinkage_table'} = $eta_file;
 320 #       $problems[ $i-1 ] -> {'wres_shrinkage_table'} = $eps_file;
 321     } else {
 322       push( @indicators, $problems[ $i-1 ] -> shrinkage_module -> status );
 323     }
 324   } else {
 325     'debug' -> die( message => "Problem number $i does not exist!" );
 326   }
 327   $j++;
 328 }
 329
 330 end shrinkage_stats
 331
 332 # }}} shrinkage_stats
 333
 334 # {{{ wres_shrinkage
 335
 336 start wres_shrinkage
 337
 338 my @problems = @{$self -> {'problems'}};
 339 foreach my $problem ( @problems ) {
 340   push( @wres_shrinkage, $problem -> wres_shrinkage );
 341 }
 342
 343 end wres_shrinkage
 344
 345 # }}} wres_shrinkage
 346
 347 # {{{ eta_shrinkage
 348
 349 start eta_shrinkage
 350
 351 my @problems = @{$self -> {'problems'}};
 352 foreach my $problem ( @problems ) {
 353   push( @eta_shrinkage, $problem -> eta_shrinkage );
 354 }
 355
 356 end eta_shrinkage
 357
 358 # }}} eta_shrinkage
 359
 360 # {{{ nonparametric_code
 361
 362 start nonparametric_code
 363
 364 if ( $#problem_numbers > 0 and $#enabled > 0 ){
 365   if ( $#problem_numbers != $#enabled ) {
 366     'debug' -> die( message => "The number of problem_numbers ".($#problem_numbers+1).
 367                     "and enabled/disabled nonparametric_code ".($#enabled+1).
 368                     "do not match" );
 369   }
 370 }
 371 unless( $#problem_numbers > 0 ){
 372   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 373 }
 374 my @problems = @{$self -> {'problems'}};
 375 my $j = 0;
 376 foreach my $i ( @problem_numbers ) {
 377   if ( defined $problems[ $i-1 ] ) {
 378     if ( defined $enabled[ $j ] ) {
 379       $problems[ $i-1 ] -> nonparametric_code( $enabled[ $j ] );
 380     } else {
 381       push( @indicators, $problems[ $i-1 ] -> nonparametric_code );
 382     }
 383   } else {
 384     'debug' -> die( message => "Problem number $i does not exist!" );
 385   }
 386   $j++;
 387 }
 388
 389 end nonparametric_code
 390
 391 # }}} nonparametric_code
 392
 393 # {{{ add_nonparametric_code
 394
 395 start add_nonparametric_code
 396
 397 $self -> set_records( type           => 'nonparametric',
 398                        record_strings => [ 'MARGINALS UNCONDITIONAL' ] );
 399 $self -> set_option( record_name => 'estimation',
 400                       option_name => 'POSTHOC' );
 401 my ( $msfo_ref, $junk ) = $self ->
 402     _get_option_val_pos( name            => 'MSFO',
 403                          record_name     => 'estimation' );
 404 my @nomegas = @{$self -> nomegas};
 405
 406 for( my $i = 0; $i <= $#nomegas; $i++ ) { # loop the problems
 407   my $marg_str = 'ID';
 408   for( my $j = 0; $j <= $nomegas[$i]; $j++ ) {
 409     $marg_str = $marg_str.' COM('.($j+1).')=MG'.($j+1);
 410   }
 411   $marg_str = $marg_str.' FILE='.$self->filename.'.marginals'.
 412       ' NOAPPEND ONEHEADER NOPRINT';
 413   $self -> add_records( problem_numbers => [($i+1)],
 414                          type            => 'table',
 415                          record_strings  => [ $marg_str ] );
 416   $self -> remove_option( record_name => 'abbreviated',
 417                            option_name => 'COMRES' );
 418   $self -> add_option( record_name  => 'abbreviated',
 419                        option_name  => 'COMRES',
 420                        option_value => ($nomegas[$i]+1),
 421                        add_record   => 1 );  #Add $ABB if not existing
 422
 423   $self -> add_marginals_code( problem_numbers => [($i+1)],
 424                                nomegas         => [ $nomegas[$i] ] );
 425 }
 426
 427 if( not defined $msfo_ref ) {
 428   for( my $i = 0; $i < $self -> nproblems; $i++ ) {
 429     $self -> add_option( record_name =>  'estimation',
 430                           option_name =>  'MSFO',
 431                           option_value => $self -> filename.'.msfo'.($i+1) );
 432   }
 433 } else {
 434   for( my $i = 0; $i < scalar @{$msfo_ref}; $i++ ) {
 435     if( not defined $msfo_ref->[$i] or not defined $msfo_ref->[$i][0] ) {
 436       $self -> add_option( record_name =>  'estimation',
 437                             option_name =>  'MSFO',
 438                             option_value => $self -> filename.'.msfo'.($i+1) );
 439     }
 440   }
 441 }
 442
 443 end add_nonparametric_code
 444
 445 # }}} add_nonparametric_code
 446
 447 # {{{ flush_data
 448
 449 start flush_data
 450       {
 451         if ( defined $self -> {'datas'} ) {
 452           foreach my $data ( @{$self -> {'datas'}} ) {
 453             $data -> flush;
 454           }
 455         }
 456       }
 457 end flush_data
 458
 459 # }}} flush_data
 460
 461 # {{{ full_name
 462
 463 start full_name
 464     {
 465         $full_name =  $self -> {'directory'} . $self -> {'filename'};
 466     }
 467 end full_name
 468
 469 # }}}
 470
 471 # {{{ sync_output
 472
 473 start __sync_output
 474       {
 475         unless( defined $self -> {'outputfile'} ){
 476           'debug' -> die( message => "No output file is set, cannot synchronize output" );
 477         }
 478         @{$self -> {'outputs'}} = ();
 479         push ( @{$self -> {'outputs'}}, output ->
 480                  new( filename             => $self -> {'outputfile'},
 481                       ignore_missing_files => $self -> {'ignore_missing_files'},
 482                       target               => $self -> {'target'},
 483                       model_id             => $self -> {'model_id'} ) );
 484       }
 485 end __sync_output
 486
 487 # }}} sync_output
 488
 489 # {{{ add_marginals_code
 490
 491 start add_marginals_code
 492
 493 # add_marginals_code takes two arguments.
 494 #
 495 # - problem_numbers is an array holding the numbers of the problems in
 496 # which code should be added.
 497 #
 498 # - nomegas which is an array holding the number of (diagonal-element)
 499 # omegas of each problem given by problem_numbers.
 500 #
 501 # For each omega in each problem, verbatim code is added to make the
 502 # marginals available for printing (e.g. to a table file). COM(1) will
 503 # hold the nonparametric density, COM(2) the marginal cumulative value
 504 # for the first eta, COM(2) the marginal cumulative density for the
 505 # second eta and so on.
 506
 507 unless( $#problem_numbers >= 0 ){
 508   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 509 }
 510
 511 my @problems = @{$self -> {'problems'}};
 512 my $j = 0;
 513 foreach my $i ( @problem_numbers ) {
 514   if ( defined $problems[ $i-1 ] ) {
 515     $problems[$i-1] -> add_marginals_code( nomegas => $nomegas[ $j ]  );
 516   } else {
 517     'debug' -> die( message => "Problem number $i does not exist.");
 518   }
 519   $j++;
 520 }
 521
 522 end add_marginals_code
 523
 524 # }}} add_marginals_code
 525
 526 # {{{ add_records
 527
 528 start add_records
 529       {
 530           # add_records is be used to add a record to a problem. The
 531           # I<record_strings> argument should be a NONMEM-formatted
 532           # record block. The type string is any of the record classes
 533           # found in the problem directory. I<problem_number> is the
 534           # index to the subproblem in the modelobject that is
 535           # modified.
 536
 537         unless( $#problem_numbers >= 0 ){
 538           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 539         }
 540
 541         my @problems = @{$self -> {'problems'}};
 542         foreach my $i ( @problem_numbers ) {
 543           if ( defined $problems[ $i-1 ] ) {
 544 #       if( defined $self -> {'problems'} ){
 545 #           if( defined @{$self -> {'problems'}}[$problem_number - 1] ){
 546 #               my $problem = @{$self -> {'problems'}}[$problem_number - 1];
 547 #               $problem -> add_records( 'type' => $type,
 548 #                                        'record_strings' => \@record_strings );
 549             $problems[$i-1] -> add_records( 'type' => $type,
 550                                             'record_strings' => \@record_strings );
 551           } else {
 552             'debug' -> die( message => "Problem number $i does not exist.");
 553           }
 554         }
 555 # else {
 556 #           'debug' -> die( message => "Model -> add_records: No Problems in model object.") ;
 557 #       }
 558       }
 559 end add_records
 560
 561 # }}} add_records
 562
 563 # {{{ set_records
 564
 565 start set_records
 566       {
 567           # set_records is be used to set a record in a problem. The
 568           # new record replaces all existing record of the same type
 569           # in the specified problem. The I<record_strings> argument
 570           # should be a NONMEM-formatted record block.  The type
 571           # string is any of the record classes found in the problem
 572           # directory. I<problem_number> is the index to the subproblem
 573           # in the modelobject that is modified.
 574
 575         unless( $#problem_numbers >= 0 ){
 576           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 577         }
 578
 579         my @problems = @{$self -> {'problems'}};
 580         foreach my $i ( @problem_numbers ) {
 581           if ( defined $problems[ $i-1 ] ) {
 582 #       if( defined $self -> {'problems'} ){
 583 #           if( defined @{$self -> {'problems'}}[$problem_number - 1] ){
 584 #               my $problem = @{$self -> {'problems'}}[$problem_number - 1];
 585 #               $problem -> set_records( 'type' => $type,
 586 #                                        'record_strings' => \@record_strings );
 587             $problems[$i-1] -> set_records( 'type' => $type,
 588                                             'record_strings' => \@record_strings );
 589           } else {
 590             'debug' -> die( "Problem number $i does not exist." );
 591           }
 592         }
 593 # else {
 594 #         'debug' -> die( "No Problems in model object.") ;
 595 #       }
 596       }
 597 end set_records
 598
 599 # }}} set_records
 600
 601 # {{{ remove_records
 602
 603 start remove_records
 604       {
 605           # set_records is be used to set a record in a problem. The
 606           # new record replaces all existing record of the same type
 607           # in the specified problem. The I<record_strings> argument
 608           # should be a NONMEM-formatted record block.  The type
 609           # string is any of the record classes found in the problem
 610           # directory. I<problem_number> is the index to the subproblem
 611           # in the modelobject that is modified.
 612
 613         unless( $#problem_numbers >= 0 ){
 614           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 615         }
 616
 617         my @problems = @{$self -> {'problems'}};
 618         foreach my $i ( @problem_numbers ) {
 619           if ( defined $problems[ $i-1 ] ) {
 620 #       if( defined $self -> {'problems'} ){
 621 #           if( defined @{$self -> {'problems'}}[$problem_number - 1] ){
 622 #               my $problem = @{$self -> {'problems'}}[$problem_number - 1];
 623 #               $problem -> remove_records( 'type' => $type );
 624             $problems[$i-1] -> remove_records( 'type' => $type );
 625           } else {
 626             'debug' -> die( message => "Problem number $i, does not exist" );
 627           }
 628         }
 629 # else {
 630 #         'debug' -> die( message => "No Problems in model object." );
 631 #       }
 632       }
 633 end remove_records
 634
 635 # }}} remove_records
 636
 637 # {{{ copy
 638
 639 start copy
 640       {
 641         # Copy produces a new modelfile object where the I<filename>
 642         # argument is the name of the file which will be used if
 643         # model::write is called on the new object.
 644         # The default behaviour of model -> copy will be to also copy
 645         # the data and output objects that are connected to the model
 646         # object. To prevent this the I<copy_data> and I<copy_output> options
 647         # may be set to 0.
 648         # The values of data_filenames, unless given,
 649         # will be the modelfilename but with '.mod' exchanged for
 650         # '_$i.dta', where $i is the problem number.
 651         # Since output objects are meant to be read-only, no
 652         # output_filename can be specified and the output object copy
 653         # will reside in memory only.
 654
 655
 656         # PP_TODO fix a nice copying of modelfile data
 657         # preferably in memory copy. Perhaps flush data ?
 658
 659         # Check sanity of the length of data file names argument
 660         if ( scalar @data_file_names > 0 ) {
 661           'debug' -> die( message => "model -> copy: The number of specified new data file " .
 662                           "names ". scalar @data_file_names. "must\n match the number".
 663                           " of data objects connected to the model object".
 664                           scalar @{$self -> {'datas'}} )
 665               unless ( scalar @data_file_names == scalar @{$self -> {'datas'}} );
 666         } else {
 667           my $d_filename;
 668           ($d_filename = $filename) =~ s/\.mod$//;
 669           for ( my $i = 1; $i <= scalar @{$self -> {'datas'}}; $i++ ) {
 670             # Data filename is created in this directory (no directory needed).
 671             push( @data_file_names, $d_filename."_data_".$i."_copy.dta" );
 672           }
 673         }
 674
 675         # Check sanity of the length of extra_data file names argument
 676         if ( scalar @extra_data_file_names > 0 ) {
 677           'debug' -> die( message => "The number of specified new extra_data file ".
 678                           "names ". scalar @extra_data_file_names, "must\n match the number".
 679                           " of problems (one extra_data file per prolem)".
 680                           scalar @{$self -> {'extra_data_files'}} )
 681               unless( scalar @extra_data_file_names == scalar @{$self -> {'extra_data_files'}} );
 682         } else {
 683           if ( defined $self -> {'extra_data_files'} ) {
 684             my $d_filename;
 685             ($d_filename = $filename) =~ s/\.mod$//;
 686             for ( my $i = 1; $i <= scalar @{$self -> {'extra_data_files'}}; $i++ ) {
 687               # Extra_Data filename is created in this directory (no directory needed).
 688               push( @extra_data_file_names, $d_filename."_extra_data_".$i."_copy.dta" );
 689             }
 690           }
 691         }
 692
 693         ($directory, $filename) = OSspecific::absolute_path( $directory, $filename );
 694
 695         # New copy:
 696
 697         # save references to own data and output objects
 698         my $datas   = $self -> {'datas'};
 699 #       $Data::Dumper::Maxdepth = 2;
 700 #       die "MC1: ", Dumper $datas -> [0] -> {'individuals'};
 701         my $outputs = $self -> {'outputs'};
 702         my %extra_datas;
 703         my @problems = @{$self -> {'problems'}};
 704         for ( my $i = 0; $i <= $#problems; $i++ ) {
 705           if ( defined $problems[$i] -> {'extra_data'} ) {
 706             $extra_datas{$i} = $problems[$i] -> {'extra_data'};
 707           }
 708         }
 709
 710         my ( @new_datas, @new_extra_datas, @new_outputs );
 711
 712         $self -> synchronize if not $self -> {'synced'};
 713
 714         # remove ref to data and output object to speed up the
 715         # cloning
 716         $self -> {'datas'}   = undef;
 717         $self -> {'outputs'} = undef;
 718         for ( my $i = 0; $i <= $#problems; $i++ ) {
 719           $problems[$i] -> {'extra_data'} = undef;
 720         }
 721
 722         # Copy the data objects if so is requested
 723         if ( defined $datas ) {
 724           my $i = 0;
 725           foreach my $data ( @{$datas} ) {
 726             if ( $copy_data == 1 ) {
 727               push( @new_datas, $data ->
 728                     copy( filename => $data_file_names[$i]) );
 729             } else {
 730               # This line assumes one data per problem! May be a source of error.
 731               my ( $cont_column, $wrap_column ) = $self -> problems -> [$i] -> cont_wrap_columns;
 732               my $ignoresign = defined $self -> ignoresigns ? $self -> ignoresigns -> [$i] : undef;
 733               my @model_header = @{$self -> problems -> [$i] -> header};
 734               push @new_datas, data ->
 735                 new( filename             => $data -> filename,
 736                      directory            => $data -> directory,
 737                      cont_column          => $cont_column,
 738                      wrap_column          => $wrap_column,
 739                      #model_header        => \@model_header,
 740                      target               => 'disk',
 741                      ignoresign           => $ignoresign,
 742                      idcolumn             => $data -> idcolumn );
 743             }
 744             $i++;
 745           }
 746         }
 747
 748         # Copy the extra_data objects if so is requested
 749         for ( my $i = 0; $i <= $#problems; $i++ ) {
 750           my $extra_data = $extra_datas{$i};
 751           if ( defined $extra_data ) {
 752             if ( $copy_data == 1 ) {
 753               push( @new_extra_datas, $extra_data ->
 754                     copy( filename => $extra_data_file_names[$i]) );
 755             } else {
 756               push( @new_extra_datas, extra_data ->
 757                     new( filename             => $extra_data -> filename,
 758                          directory            => $extra_data -> directory,
 759                          target               => 'disk',
 760                          idcolumn             => $extra_data -> idcolumn ) );
 761             }
 762           }
 763         }
 764
 765
 766         # Clone self into new model object and set synced to 0 for
 767         # the copy
 768         $new_model = Storable::dclone( $self );
 769         $new_model -> {'synced'} = 0;
 770
 771 #       $Data::Dumper::Maxdepth = 3;
 772 #       die Dumper $new_datas[0] -> {'individuals'};
 773
 774         # Restore the data and output objects for self
 775         $self -> {'datas'} = $datas;
 776         $self -> {'outputs'} = $outputs;
 777         for ( my $i = 0; $i <= $#problems; $i++ ) {
 778           if( defined $extra_datas{$i} ){
 779             $problems[$i] -> {'extra_data'} = $extra_datas{$i};
 780           }
 781         }
 782
 783         # Set the new file name for the copy
 784         $new_model -> directory( $directory );
 785         $new_model -> filename( $filename );
 786
 787         # {{{ update the shrinkage modules
 788
 789         my @problems = @{$new_model -> problems};
 790         for( my $i = 1; $i <= scalar @problems; $i++ ) {
 791           $problems[ $i-1 ] -> shrinkage_module -> model( $new_model );
 792         }
 793
 794         # }}} update the shrinkage modules
 795
 796         # Copy the output object if so is requested (only one output
 797         # object defined per model object)
 798         if ( defined $outputs ) {
 799           foreach my $output ( @{$outputs} ) {
 800             if ( $copy_output == 1 ) {
 801               push( @new_outputs, $output -> copy );
 802             } else {
 803               my $new_out = $filename;
 804               $new_out =~ s/\.mod$/\.lst/;
 805               push( @new_outputs, output ->
 806                     new ( filename => $new_out,
 807                           directory => $directory,
 808                           target   => 'disk',
 809                           ignore_missing_files => 1,
 810                           model_id => $new_model -> {'model_id'} ) );
 811             }
 812           }
 813         }
 814
 815         # Add the copied data and output objects to the model copy
 816         $new_model -> datas( \@new_datas );
 817
 818         if ( $#new_extra_datas >= 0 ) {
 819           my @new_problems = @{$new_model -> problems};
 820           for ( my $i = 0; $i <= $#new_problems; $i++ ) {
 821             $new_problems[$i] -> {'extra_data'} = $new_extra_datas[$i];
 822             if ( $copy_data == 1 ){
 823               $new_problems[$i] -> {'extra_data_file_name'} = $extra_data_file_names[$i];
 824             }
 825           }
 826         }
 827
 828         $new_model -> {'outputs'} = \@new_outputs;
 829
 830         $new_model -> _write;
 831
 832         $new_model -> synchronize if $target eq 'disk';
 833       }
 834 end copy
 835
 836 # }}} copy
 837
 838 # {{{ covariance
 839
 840 start covariance
 841       {
 842         if ( $#problem_numbers > 0 ){
 843           if ( $#problem_numbers != $#enabled ) {
 844             'debug' -> die( message => "The number of problem_numbers ".($#problem_numbers+1).
 845                           "and enabled/disabled covariance records ".($#enabled+1).
 846                           "do not match" );
 847           }
 848         }
 849         unless( $#problem_numbers > 0 ){
 850           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 851         }
 852         my @problems = @{$self -> {'problems'}};
 853         my $j = 0;
 854         foreach my $i ( @problem_numbers ) {
 855           if ( defined $problems[ $i-1 ] ) {
 856             if ( defined $enabled[ $j ] ) {
 857               $problems[ $i-1 ] -> covariance( enabled => $enabled[ $j ] );
 858             } else {
 859               push( @indicators, $problems[ $i-1 ] -> covariance );
 860             }
 861           } else {
 862             'debug' -> die( message => "Problem number $i does not exist!" );
 863           }
 864           $j++;
 865         }
 866       }
 867 end covariance
 868
 869 # }}} covariance
 870
 871 # {{{ datas
 872
 873 start datas
 874       {
 875         my $nprobs = scalar @{$self -> {'problems'}};
 876         if ( defined $parm ) {
 877           if ( ref($parm) eq 'ARRAY' ) {
 878             my @new_datas = @{$parm};
 879             # Check that new_headers and problems match
 880             'debug' -> die( message => "The number of problems $nprobs and".
 881                             " new data ". $#new_datas+1 ." don't match in ".
 882                             $self -> full_name ) unless ( $#new_datas + 1 == $nprobs );
 883             if ( defined $self -> {'problems'} ) {
 884               for( my $i = 0; $i < $nprobs; $i++ ) {
 885                 $self -> _option_name( position   => 0,
 886                                        record     => 'data',
 887                                        problem_number => $i+1,
 888                                        new_name   => $new_datas[$i] -> filename);
 889               }
 890             } else {
 891               'debug' -> die( message => "No problems defined in ".
 892                               $self -> full_name );
 893             }
 894           } else {
 895             'debug' -> die( message => "Supplied new value is not an array" );
 896           }
 897         }
 898       }
 899 end datas
 900
 901  # }}}
 902
 903 # {{{ datafile
 904
 905 start datafile
 906       {
 907         # datafile either retrieves or sets a new name for the datafile in the first problem of the
 908         # model. This method is only here for compatibility reasons. Don't use it. Use L</datafiles> instead.
 909
 910         if( defined $new_name ){
 911           $self -> _option_name( position => 0,
 912                                  record   => 'data',
 913                                  problem_number  => $problem_number,
 914                                  new_name => $new_name);
 915           my ( $cont_column, $wrap_column ) = $self -> problems -> [$problem_number-1] ->
 916             cont_wrap_columns;
 917           my $ignoresign = defined $self -> ignoresigns ?
 918             $self -> ignoresigns -> [$problem_number-1] : undef;
 919           my @model_header = @{$self -> problems -> [$problem_number-1] -> header};
 920           $self -> {'datas'} -> [$problem_number-1] = data ->
 921             new( idcolumn             => $self -> idcolumn( problem_number => $problem_number ),
 922                  ignoresign           => $ignoresign,
 923                  filename             => $new_name,
 924                  cont_column          => $cont_column,
 925                  wrap_column          => $wrap_column,
 926                  #model_header         => \@model_header,
 927                  ignore_missing_files => $self -> {'ignore_missing_files'},
 928                  target               => $self -> {'target'} );
 929         } else {
 930             $name = $self -> _option_name( position => 0, record => 'data', problem_number => $problem_number );
 931         }
 932       }
 933 end datafile
 934
 935 # }}} datafile
 936
 937 # {{{ datafiles
 938
 939 start datafiles
 940       {
 941         # The datafiles method retrieves or sets the names of the
 942         # datafiles specified in the $DATA record of each problem. The
 943         # problem_numbers argument can be used to control which
 944         # problem that is affected. If absolute_path is set to 1, the
 945         # returned file names are given with absolute paths.
 946
 947         unless( $#problem_numbers > 0 ){
 948           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 949         }
 950         if ( scalar @new_names > 0 ) {
 951           my $i = 0;
 952           my @idcolumns = @{$self ->
 953                               idcolumns( problem_numbers => \@problem_numbers )};
 954           foreach my $new_name ( @new_names ) {
 955             if ( $absolute_path ) {
 956               my $tmp;
 957               ($tmp, $new_name) = OSspecific::absolute_path('', $new_name );
 958               $new_name = $tmp . $new_name;
 959             }
 960
 961             $self -> _option_name( position       => 0,
 962                                    record         => 'data',
 963                                    problem_number => $problem_numbers[$i],
 964                                    new_name       => $new_name);
 965             my ( $cont_column, $wrap_column ) = $self -> problems ->
 966               [$problem_numbers[$i]-1] -> cont_wrap_columns;
 967             my $ignoresign = defined $self -> ignoresigns ? $self -> ignoresigns -> [$i] : undef;
 968             my @model_header = @{$self -> problems -> [$i] -> header};
 969             $self -> {'datas'} -> [$problem_numbers[$i]-1] = data ->
 970               new( idcolumn             => $idcolumns[$i],
 971                    ignoresign           => $ignoresign,
 972                    filename             => $new_name,
 973                    cont_column          => $cont_column,
 974                    wrap_column          => $wrap_column,
 975                    #model_header         => \@model_header,
 976                    ignore_missing_files => $self -> {'ignore_missing_files'},
 977                    target               => $self -> {'target'} );
 978             $i++;
 979           }
 980         } else {
 981           foreach my $prob_num ( @problem_numbers ) {
 982             if ( $absolute_path ) {
 983               my ($d_dir, $d_name);
 984               ($d_dir, $d_name) =
 985                   OSspecific::absolute_path($self -> {'directory'}, $self ->_option_name( position       => 0,
 986                                                                                           record         => 'data',
 987                                                                                           problem_number => $prob_num ) );
 988               push( @names, $d_dir . $d_name );
 989             } else {
 990               my $name = $self -> _option_name( position       => 0,
 991                                                 record         => 'data',
 992                                                 problem_number => $prob_num );
 993               $name =~ s/.*[\/\\]//;
 994               push( @names, $name );
 995             }
 996           }
 997         }
 998       }
 999 end datafiles
1000
1001 # }}} datafiles
1002
1003 # {{{ des
1004
1005 start des
1006       {
1007         # Returns the des part specified subproblem.
1008         # TODO: Even though new_des can be specified, they wont be set
1009         # in to the object.
1010
1011         my @prob = @{$self    -> problems};
1012         my @des  = @{$prob[$problem_number - 1] -> get_record('des') -> code}
1013         if ( defined $prob[$problem_number - 1] -> get_record('des') );
1014       }
1015 end des
1016
1017 # }}} des
1018
1019 # {{{ eigen
1020 start eigen
1021       {
1022         $self -> {'problems'} -> [0] -> eigen;
1023       }
1024 end eigen
1025 # }}} eigen
1026
1027 # {{{ error
1028
1029 start error
1030       {
1031         # Usage:
1032         #
1033         # @error = $modelObject -> error;
1034         #
1035         # Returns the error part specified subproblem.
1036         # TODO: Even though new_error can be specified, they wont be set
1037         # in to the object.
1038         my @prob = @{$self    -> problems};
1039         my @error = @{$prob[0] -> get_record('error') -> code}
1040           if ( defined $prob[0] -> get_record('error') );
1041       }
1042 end error
1043
1044 # }}} error
1045
1046 # {{{ extra_data_files
1047
1048 start extra_data_files
1049       {
1050         my @file_names;
1051         # Sets or retrieves extra_data_file_name on problem level
1052         my $nprobs = scalar @{$self -> {'problems'}};
1053         if ( defined $parm ) {
1054           if ( ref($parm) eq 'ARRAY' ) {
1055             my @new_file_names = @{$parm};
1056             # Check that new_file_names and problems match
1057             'debug' -> die( message => "model -> extra_data_files: The number of problems $nprobs and" .
1058                             " new_file_names " . $#new_file_names+1 . " don't match in ".
1059                             $self -> full_name ) unless ( $#new_file_names + 1 == $nprobs );
1060             if ( defined $self -> {'problems'} ) {
1061               for( my $i = 0; $i < $nprobs; $i++ ) {
1062                 $self -> {'problems'} -> [$i] -> extra_data_file_name( $new_file_names[$i] );
1063               }
1064             } else {
1065               'debug' -> die( message => "No problems defined in " .
1066                               $self -> full_name );
1067             }
1068           } else {
1069             'debug' -> die(message => "Supplied new value is not an array.");
1070           }
1071         } else {
1072           if ( defined $self -> {'problems'} ) {
1073             for( my $i = 0; $i < $nprobs; $i++ ) {
1074               if( defined $self -> {'problems'} -> [$i] -> extra_data_file_name ) {
1075                 push ( @file_names ,$self -> {'problems'} -> [$i] -> extra_data_file_name );
1076               }
1077             }
1078           }
1079         }
1080         return \@file_names;
1081      }
1082 end extra_data_files
1083
1084 # }}}
1085
1086 # {{{ extra_data_headers
1087
1088 start extra_data_headers
1089       {
1090         my @headers;
1091         # Sets or retrieves extra_data_header on problem level
1092         my $nprobs = scalar @{$self -> {'problems'}};
1093         if ( defined $parm ) {
1094           if ( ref($parm) eq 'ARRAY' ) {
1095             my @new_headers = @{$parm};
1096             # Check that new_headers and problems match
1097             'debug' -> die( message => "The number of problems $nprobs and".
1098                             " new_headers " . $#new_headers+1 . " don't match in ".
1099                             $self -> full_name) unless ( $#new_headers + 1 == $nprobs );
1100             if ( defined $self -> {'problems'} ) {
1101               for( my $i = 0; $i < $nprobs; $i++ ) {
1102                 $self -> {'problems'} -> [$i] -> extra_data_header( $new_headers[$i] );
1103               }
1104             } else {
1105               'debug' -> die( message => "No problems defined in " .  $self -> full_name );
1106             }
1107           } else {
1108             'debug' -> die( message => "Supplied new value is not an array" );
1109           }
1110         } else {
1111           if ( defined $self -> {'problems'} ) {
1112             for( my $i = 0; $i < $nprobs; $i++ ) {
1113               push ( @headers, $self -> {'problems'} -> [$i] -> extra_data_header );
1114             }
1115           }
1116         }
1117         return \@headers;
1118      }
1119 end extra_data_headers
1120
1121 # }}} extra_data_headers
1122
1123 # {{{ factors
1124
1125 start factors
1126       {
1127         # Calls <I>factors</I> on the data object of a specified
1128         # problem. See <I>data -> factors</I> for details.
1129         my $column_number;
1130         my $extra_data_column;
1131         if ( defined $column_head ) {
1132           # Check normal data object first
1133           my ( $values_ref, $positions_ref ) = $self ->
1134             _get_option_val_pos ( problem_numbers => [$problem_number],
1135                                   name        => $column_head,
1136                                   record_name => 'input',
1137                                   global_position => 1 );
1138           $column_number = $positions_ref -> [0];
1139           # Next, check extra_data
1140           my $extra_data_headers = $self -> extra_data_headers;
1141           if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
1142             for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
1143               $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
1144             }
1145           }
1146           'debug' -> die( message => "Unknown column \"$column_head\"" )
1147               unless ( defined $column_number or defined $extra_data_column );
1148         } else {
1149           $column_number = $column;
1150         }
1151         if ( defined $column_number) {
1152           %factors = %{$self -> {'datas'} -> [$problem_number-1] ->
1153                          factors( column => $column_number,
1154                                   unique_in_individual => $unique_in_individual,
1155                                   return_occurences => $return_occurences )};
1156         } else {
1157           %factors = %{$self -> {'problems'} -> [$problem_number-1] -> extra_data
1158                          -> factors( column => $extra_data_column,
1159                                      unique_in_individual => $unique_in_individual,
1160                                      return_occurences => $return_occurences )};
1161         }
1162       }
1163 end factors
1164
1165 # }}}
1166
1167 # {{{ fractions
1168
1169 start fractions
1170       {
1171         # Calls <I>fractions</I> on the data object of a specified
1172         # problem. See <I>data -> fractions</I> for details.
1173         my $column_number;
1174         my $extra_data_column;
1175         if ( defined $column_head ) {
1176           # Check normal data object first
1177           my ( $values_ref, $positions_ref ) = $self ->
1178             _get_option_val_pos ( problem_numbers => [$problem_number],
1179                                   name        => $column_head,
1180                                   record_name => 'input',
1181                                   global_position => 1 );
1182           $column_number = $positions_ref -> [0];
1183           # Next, check extra_data
1184           my $extra_data_headers = $self -> extra_data_headers;
1185           if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
1186             for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
1187               $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
1188             }
1189           }
1190           'debug' -> die( "Unknown column \"$column_head\"" )
1191               unless ( defined $column_number or defined $extra_data_column );
1192         } else {
1193           $column_number = $column;
1194         }
1195         if ( defined $column_number) {
1196           %fractions = %{$self -> {'datas'} -> [$problem_number-1] ->
1197                            fractions( column => $column_number,
1198                                       unique_in_individual => $unique_in_individual,
1199                                       ignore_missing       => $ignore_missing )};
1200         } else {
1201           %fractions = %{$self -> {'problems'} -> [$problem_number-1] -> extra_data
1202                            -> fractions( column               => $extra_data_column,
1203                                          unique_in_individual => $unique_in_individual,
1204                                          ignore_missing       => $ignore_missing )};
1205         }
1206       }
1207 end fractions
1208
1209 # }}}
1210
1211 # {{{ fixed
1212
1213 start fixed
1214       {
1215           # Sets or gets the 'fixed' status of a (number of)
1216           # parameter(s). 1 correspond to a parameter being fixed and
1217           # 0 not fixed. The returned parameter is a reference to a
1218           # two-dimensional array, indexed by problems and parameter
1219           # numbers.
1220           # Valid parameter types are 'theta', 'omega' and 'sigma'.
1221
1222         @fixed = @{ $self -> _init_attr
1223                       ( parameter_type    => $parameter_type,
1224                         parameter_numbers => \@parameter_numbers,
1225                         problem_numbers           => \@problem_numbers,
1226                         new_values        => \@new_values,
1227                         attribute         => 'fix')};
1228       }
1229 end fixed
1230
1231 # }}} fixed
1232
1233 # {{{ have_missing_data
1234
1235 start have_missing_data
1236       {
1237         # Calls <I>have_missing_data</I> on the data object of a specified
1238         # problem. See <I>data -> have_missing_data</I> for details.
1239         my $column_number;
1240         my $extra_data_column;
1241         if ( defined $column_head ) {
1242           # Check normal data object first
1243           my ( $values_ref, $positions_ref ) = $self ->
1244             _get_option_val_pos ( problem_numbers => [$problem_number],
1245                                   name        => $column_head,
1246                                   record_name => 'input',
1247                                   global_position => 1  );
1248           $column_number = $positions_ref -> [0];
1249           # Next, check extra_data
1250           my $extra_data_headers = $self -> extra_data_headers;
1251           if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
1252             for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
1253               $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
1254             }
1255           }
1256           'debug' -> die( message => "Unknown column \"$column_head\"" )
1257               unless ( defined $column_number or defined $extra_data_column );
1258         } else {
1259           $column_number = $column;
1260         }
1261         if ( defined $column_number) {
1262           $return_value = $self -> {'datas'} -> [$problem_number-1] ->
1263             have_missing_data( column => $column_number );
1264         } else {
1265           $return_value = $self -> {'problems'} -> [$problem_number-1] ->
1266             extra_data -> have_missing_data( column => $extra_data_column );
1267         }
1268     }
1269 end have_missing_data
1270
1271 # }}}
1272
1273 # {{{ idcolumn
1274
1275 start idcolumn
1276       {
1277         # Usage:
1278         #
1279         #   @idcolumns = @{$modelObject -> idcolumns( problem_numbers => [2,3] );
1280         #
1281         # idcolumns returns the idcolumn index in the datafile for the
1282         # specified problem.
1283
1284         my $junk_ref;
1285         ( $junk_ref, $col ) = $self ->
1286           _get_option_val_pos( name => 'ID',
1287                                record_name => 'input',
1288                                problem_numbers => [$problem_number] );
1289
1290         if ( $problem_number ne 'all' ) {
1291           $col = @{$col}[0];
1292         }
1293       }
1294 end idcolumn
1295
1296 # }}} idcolumn
1297
1298 # {{{ idcolumns
1299
1300 start idcolumns
1301       {
1302         # Usage:
1303         #
1304         #   @column_numbers = @{$modelObject -> idcolumns( problem_numbers => [2] )};
1305         #
1306         # idcolumns returns the idcolumn indexes in the datafile for the
1307         # specified problems.
1308
1309         my ( $junk_ref, $col_ref ) = $self ->
1310           _get_option_val_pos( name            => 'ID',
1311                                record_name     => 'input',
1312                                problem_numbers => \@problem_numbers );
1313         # There should only be one instance of $INPUT and hence we collapse
1314         # the two-dim return from _get_option_pos_val to a one-dim array:
1315
1316         foreach my $prob ( @{$col_ref} ) {
1317           foreach my $inst ( @{$prob} ) {
1318             push( @column_numbers, $inst );
1319           }
1320         }
1321       }
1322 end idcolumns
1323
1324 # }}} idcolumns
1325
1326 # {{{ ignoresigns
1327
1328 start ignoresigns
1329       {
1330         # Usage:
1331         #
1332         #   @ignore_signs = @{$modelObject -> ignoresigns( problem_numbers => [2,4] )};
1333         #
1334         # ignoresigns returns the ignore signs in the datafile for the
1335         # specified problems
1336
1337         my ( $ignore_opt_ref, $junk_ref ) = $self ->
1338           _get_option_val_pos( name            => 'IGNORE',
1339                                record_name     => 'data',
1340                                problem_numbers => \@problem_numbers );
1341
1342         # There should only be one instance of $DATA and hence we collapse
1343         # the two-dim return from _get_option_pos_val to a one-dim array:
1344         foreach my $prob ( @{$ignore_opt_ref} ) {
1345           foreach my $inst ( @{$prob} ) {
1346             $inst = '#' unless defined $inst;
1347             push( @ignore, $inst );
1348           }
1349         }
1350       }
1351 end ignoresigns
1352
1353 # }}} ignoresigns
1354
1355 # {{{ indexes
1356
1357 start indexes
1358       {
1359         # Usage:
1360         #
1361         #   @indexArray = @{$modelObject -> indexes( 'parameter_type' => 'omega' )};
1362         #
1363         # A call to I<indexes> returns the indexes of all parameters
1364         # specified in I<parameter_numbers> from the subproblems
1365         # specified in I<problem_numbers>. The method returns a reference to an array that has
1366         # the same structure as parameter_numbers but for each
1367         # array of numbers is instead an array of indices. The method
1368         # uses a method from the model::problem class to format the
1369         # indices, so here are a few lines from the code comments in
1370         # model/problem.pm that describes the returned value:
1371         #
1372         # <snip>
1373         # The Indexes method calculates the index for a
1374         # parameter. Off-diagonal elements will get a index 'i_j', where i
1375         # is the row number and j is the column number
1376         # </snip>
1377
1378         unless( $#problem_numbers > 0 ){
1379           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
1380         }
1381         my @problems = @{$self -> {'problems'}};
1382         foreach my $i ( @problem_numbers ) {
1383           if ( defined $problems[ $i-1 ] ) {
1384             push( @indexes,
1385                   $problems[ $i-1 ] ->
1386                   indexes( parameter_type => $parameter_type,
1387                            parameter_numbers => $parameter_numbers[ $i-1 ] ) );
1388           } else {
1389             'debug' -> die( message => "Problem number $i does not exist!" );
1390           }
1391         }
1392       }
1393 end indexes
1394
1395 # }}} indexes
1396
1397 # {{{ initial_values
1398
1399 start initial_values
1400       {
1401           # initial_values either sets or gets the initial values of
1402           # the parameter specified in "parameter_type" for each
1403           # problem specified in problem_numbers. For each element
1404           # in problem_numbers there must be a reference in
1405           # parameter_numbers to an array that specify the indices
1406           # of the parameters in the subproblem for which the initial
1407           # values are set, replaced or retrieved.
1408           #
1409           # The add_if_absent argument tells the method to add an init
1410           # (theta,omega,sigma) if the parameter number points to a
1411           # non-existing parameter with parameter number one higher
1412           # than the highest presently included. Only applicable if
1413           # new_values are set. Valid parameter types are 'theta',
1414           # 'omega' and 'sigma'.
1415
1416         @initial_values = @{ $self -> _init_attr
1417                                  ( parameter_type    => $parameter_type,
1418                                    parameter_numbers => \@parameter_numbers,
1419                                    problem_numbers   => \@problem_numbers,
1420                                    new_values        => \@new_values,
1421                                    attribute         => 'init',
1422                                    add_if_absent     => $add_if_absent )};
1423       }
1424 end initial_values
1425
1426 # }}} initial_values
1427
1428 # {{{ is_option_set
1429
1430 start is_option_set
1431       {
1432         # Usage:
1433         #
1434         # if( $modelObject -> is_option_set( record => 'recordName', name => 'optionName' ) ){
1435         #     print "problem_number 1 has option optionName set in record recordName";
1436         # }
1437         #
1438         # is_option_set checks if an option is set in a given record in given problem.
1439
1440         my ( @problems, @records, @options );
1441         my $accessor = $record.'s';
1442         if ( defined $self -> {'problems'} ) {
1443             @problems = @{$self -> {'problems'}};
1444         } else {
1445           'debug' -> die( message => "No problems defined in model" );
1446         }
1447         unless( defined $problems[$problem_number - 1] ){
1448             'debug' -> warn( level => 2,
1449                            message => "model -> is_option_set: No problem number $problem_number defined in model" );
1450             return 0; # No option can be set if no problem exists.
1451         }
1452
1453         if ( defined $problems[$problem_number - 1] -> $accessor ) {
1454             @records = @{$problems[$problem_number - 1] -> $accessor};
1455         } else {
1456             'debug' -> warn( level => 2,
1457                            message => "model -> is_option_set: No record $record defined" .
1458                            " in problem number $problem_number." );
1459             return 0;
1460         }
1461
1462         unless(defined $records[$instance - 1] ){
1463             'debug' -> warn( level => 2,
1464                            message => "model -> is_option_set: No record instance number $instance defined in model." );
1465             return 0;
1466         }
1467
1468         if ( defined $records[$instance - 1] -> options ) {
1469             @options = @{$records[$instance - 1] -> options};
1470         } else {
1471           'debug' -> warn( level => 2,
1472                            message => "No option defined in record: $record in problem number $problem_number." );
1473             return 0;
1474         }
1475         foreach my $option ( @options ) {
1476             $found = 1 if ( defined $option and $option -> name eq $name );
1477         }
1478       }
1479 end is_option_set
1480
1481 # }}} is_option_set
1482
1483 # {{{ is_run
1484 start is_run
1485       {
1486         # Usage:
1487         #
1488         # is_run returns true if the outputobject owned by the
1489         # modelobject has valid outpudata either in memory or on disc.
1490         if( defined $self -> {'outputs'} ){
1491           if( @{$self -> {'outputs'}}[0] -> have_output ){
1492             $return_value = 1;
1493           }
1494         } else {
1495           $return_value = 0;
1496         }
1497       }
1498 end is_run
1499 # }}} is_run
1500
1501 # {{{ is_simulation
1502
1503 start is_simulation
1504     {
1505       my $problems = $self -> {'problems'};
1506       if( defined $problems -> [$problem_number - 1] ) {
1507         my $problem = $problems -> [$problem_number - 1];
1508         # If we don't have an ESTIMATION record we are simulating.
1509         $is_sim = 1 unless( defined $problem -> {'estimations'} and
1510                          scalar( @{$problem-> {'estimations'}} ) > 0 );
1511
1512         # If we have a ONLYSIM option in the simulation record.
1513         $is_sim = 1 if( $self -> is_option_set ( name           => 'ONLYSIM',
1514                                                  record         => 'simulation',
1515                                                  problem_number => $problem_number ));
1516
1517         # If max evaluations is zero we are simulating
1518         $is_sim = 1 if( defined $self -> maxeval(problem_numbers => [$problem_number]) and
1519                         defined $self -> maxeval(problem_numbers => [$problem_number])->[0][0] and
1520                         $self -> maxeval(problem_numbers => [$problem_number])->[0][0] == 0 );
1521
1522         # Anything else?
1523
1524         # If non of the above is true, we are estimating.
1525       } else {
1526         'debug' -> warn( level => 1,
1527                          message => 'Problem nr. $problem_number not defined. Assuming no simulation' );
1528         $is_sim = 0;
1529       }
1530     }
1531 end is_simulation
1532
1533 # }}}
1534
1535 # {{{ lower_bounds
1536
1537 start lower_bounds
1538       {
1539           # lower_bounds either sets or gets the initial values of the
1540           # parameter specified in the argument parameter_type for
1541           # each problem specified in problem_numbers. See L</fixed>.
1542
1543         @lower_bounds = @{ $self -> _init_attr
1544                              ( parameter_type    => $parameter_type,
1545                                parameter_numbers => \@parameter_numbers,
1546                                problem_numbers           => \@problem_numbers,
1547                                new_values        => \@new_values,
1548                                attribute         => 'lobnd')};
1549       }
1550 end lower_bounds
1551
1552 # }}} lower_bounds
1553
1554 # {{{ labels
1555
1556 start labels
1557       {
1558         # Usage:
1559         #
1560         #   @labels = @{$modobj -> labels( parameter_type => 'theta' )};
1561         #
1562         # This basic usage takes one arguments and returns matched names and
1563         # estimated values of the specified parameter. The parameter_type argument
1564         # is mandatory. It returns the labels of all parameters of type given by
1565         # $parameter_type.
1566         # @labels will be a two-dimensional array:
1567         # [[label1][label2][label3]...]
1568         #
1569         #   $labels -> labels( parameter_type  => 'theta',
1570         #                      problem_numbers => [2,4] );
1571         #
1572         # To get labels of specific problems, the problem_numbers argument can be used.
1573         # It should be a reference to an array containing the numbers
1574         # of all problems whos labels should be retrieved.
1575         #
1576         #   $modobj -> labels( parameter_type    => 'theta',
1577         #                      problem_numbers   => [2,4],
1578         #                      parameter_numbers => [[1,3][4,6]]);
1579         #
1580         # The retrieval can be even more specific by using the parameter_numbers
1581         # argument. It should be a reference to a two-dimensional array, where
1582         # the inner arrays holds the numbers of the parameters that should be
1583         # fetched. In the example above, parameters one and three from problem two
1584         # plus parameters four and six from problem four are retrieved.
1585         #
1586         #   $modobj -> labels( parameter_type    => 'theta',
1587         #                      problem_numbers   => [2,4],
1588         #                      parameter_numbers => [[1,3][4,6]],
1589         #                      generic           => 1 );
1590         #
1591         # To get generic labels for the parameters - e.g. OM1, OM2_1, OM2 etc -
1592         # set the generic argument to 1.
1593         #
1594         # $modobj -> labels( parameter_type     => 'theta',
1595         #                     problem_numbers   => [2],
1596         #                     parameter_numbers => [[1,3]],
1597         #                     new_values        => [['Volume','Clearance']] );
1598         #
1599         # The new_values argument can be used to give parameters new labels. In
1600         # the above example, parameters one and three in problem two are renamed
1601         # Volume and Clearance.
1602         #
1603
1604         my ( @index, $idx );
1605         @labels = @{ $self -> _init_attr
1606                        ( parameter_type    => $parameter_type,
1607                          parameter_numbers => \@parameter_numbers,
1608                          problem_numbers           => \@problem_numbers,
1609                          new_values        => \@new_values,
1610                          attribute         => 'label' )};
1611
1612         #       foreach my $prl ( @labels ) {
1613         #         foreach my $label ( @{$prl} ) {
1614         #           print "Label: $label\n";
1615         #         }
1616         #       }
1617
1618
1619         @index = @{$self -> indexes( parameter_type => $parameter_type,
1620                                      parameter_numbers => \@parameter_numbers,
1621                                      problem_numbers => \@problem_numbers )};
1622         for ( my $i = 0; $i <= $#labels; $i++ ) {
1623           for ( my $j = 0; $j < scalar @{$labels[$i]}; $j++ ) {
1624             $idx = $index[$i][$j];
1625             $labels[$i][$j] = uc(substr($parameter_type,0,2)).$idx
1626               unless ( defined $labels[$i][$j] and not $generic );
1627           }
1628         }
1629       }
1630 end labels
1631
1632 # }}} labels
1633
1634 # {{{ maxeval
1635
1636 start maxeval
1637       {
1638         # Usage:
1639         #
1640         #   @maxev = @{$modobj -> maxeval};
1641         #
1642         # This basic usage takes no arguments and returns the value of the
1643         # MAXEVAL option in the $ESTIMATION record of each problem.
1644         # @maxev will be a two dimensional array:
1645         # [[maxeval_prob1][maxeval_prob2][maxeval_prob3]...]
1646         #
1647         #   $modobj -> maxeval( new_values => [[0],[999]];
1648         #
1649         # If the new_values argument of maxeval is given, the values of the
1650         # MAXEVAL options will be changed. In this example, MAXEVAL will be
1651         # set to 0 in the first problem and to 999 in the second.
1652         # The number of elements in new_values must match the number of problems
1653         # in the model object $modobj.
1654         #
1655         #   $modobj -> maxeval( new_values => [[0],[999]],
1656         #                       problem_numbers    => [2,4] );
1657         #
1658         # To set the MAXEVAL of specific problems, the problem_numbers argument can
1659         # be used. It should be a reference to an array containing the numbers
1660         # of all problems where the MAXEVAL should be changed or retrieved.
1661         # If specified, the size of new_values must be the same as the size
1662         # of problem_numbers.
1663         #
1664
1665
1666
1667         my ( $val_ref, $junk ) = $self ->
1668           _option_val_pos( name            => 'MAX',
1669                            record_name     => 'estimation',
1670                            problem_numbers => \@problem_numbers,
1671                            new_values      => \@new_values,
1672                            exact_match     => $exact_match );
1673         @values = @{$val_ref};
1674       }
1675 end maxeval
1676
1677 # }}} maxeval
1678
1679 # {{{ median
1680
1681 start median
1682       {
1683         # Calls <I>median</I> on the data object of a specified
1684         # problem. See <I>data -> median</I> for details.
1685         my $column_number;
1686         my $extra_data_column;
1687         if ( defined $column_head ) {
1688           # Check normal data object first
1689           my ( $values_ref, $positions_ref ) = $self ->
1690             _get_option_val_pos ( problem_numbers => [$problem_number],
1691                                   name        => $column_head,
1692                                   record_name => 'input',
1693                                   global_position => 1  );
1694           $column_number = $positions_ref -> [0];
1695           if ( not defined $column_number ) {
1696             # Next, check extra_data
1697             my $extra_data_headers = $self -> extra_data_headers;
1698             if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
1699               for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
1700                 $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
1701               }
1702             }
1703           }
1704           'debug' -> die( message => "Unknown column \"$column_head\"" )
1705               unless ( defined $column_number or defined $extra_data_column );
1706         } else {
1707           $column_number = $column;
1708         }
1709
1710         if ( defined $column_number) {
1711           $median = $self -> {'datas'} -> [$problem_number-1] ->
1712             median( column => $column_number,
1713                     unique_in_individual => $unique_in_individual );
1714         } else {
1715           $median = $self -> {'problems'} -> [$problem_number-1] -> extra_data ->
1716             median( column => $extra_data_column,
1717                     unique_in_individual => $unique_in_individual );
1718         }
1719     }
1720 end median
1721
1722 # }}}
1723
1724 # {{{ max
1725
1726 start max
1727       {
1728         # Calls <I>max</I> on the data object of a specified
1729         # problem. See <I>data -> max</I> for details.
1730         my $column_number;
1731         my $extra_data_column;
1732         if ( defined $column_head ) {
1733           # Check normal data object first
1734           my ( $values_ref, $positions_ref ) = $self ->
1735             _get_option_val_pos ( problem_numbers => [$problem_number],
1736                                   name        => $column_head,
1737                                   record_name => 'input',
1738                                   global_position => 1  );
1739           $column_number = $positions_ref -> [0];
1740           if ( not defined $column_number ) {
1741             # Next, check extra_data
1742             my $extra_data_headers = $self -> extra_data_headers;
1743             if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
1744               for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
1745                 $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
1746               }
1747             }
1748           }
1749           'debug' -> die( message => "Unknown column \"$column_head\"" )
1750               unless ( defined $column_number or defined $extra_data_column );
1751         } else {
1752           $column_number = $column;
1753         }
1754
1755         if ( defined $column_number) {
1756           $max = $self -> {'datas'} -> [$problem_number-1] ->
1757             max( column => $column_number );
1758         } else {
1759           $max = $self -> {'problems'} -> [$problem_number-1] -> extra_data ->
1760             max( column => $extra_data_column );
1761         }
1762       }
1763 end max
1764
1765 # }}}
1766
1767 # {{{ min
1768
1769 start min
1770       {
1771         # Calls <I>min</I> on the data object of a specified
1772         # problem. See <I>data -> min</I> for details.
1773         my $column_number;
1774         my $extra_data_column;
1775         if ( defined $column_head ) {
1776           # Check normal data object first
1777           my ( $values_ref, $positions_ref ) = $self ->
1778             _get_option_val_pos ( problem_numbers => [$problem_number],
1779                                   name        => $column_head,
1780                                   record_name => 'input',
1781                                   global_position => 1  );
1782           $column_number = $positions_ref -> [0];
1783           if ( not defined $column_number ) {
1784             # Next, check extra_data
1785             my $extra_data_headers = $self -> extra_data_headers;
1786             if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
1787               for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
1788                 $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
1789               }
1790             }
1791           }
1792           'debug' -> die( message => "Unknown column \"$column_head\"" )
1793               unless ( defined $column_number or defined $extra_data_column );
1794         } else {
1795           $column_number = $column;
1796         }
1797
1798         if ( defined $column_number) {
1799           $min = $self -> {'datas'} -> [$problem_number-1] ->
1800             min( column => $column_number );
1801         } else {
1802           $min = $self -> {'problems'} -> [$problem_number-1] -> extra_data ->
1803             min( column => $extra_data_column );
1804         }
1805     }
1806 end min
1807
1808 # }}}
1809
1810 # {{{ name_val
1811
1812 start name_val
1813       {
1814         # Usage:
1815         #
1816         #   @name_val = @{$modobj -> name_val( parameter_type => 'theta' )};
1817         #
1818         # This basic usage takes one arguments and returns matched names and
1819         # estimated values of the specified parameter. The parameter_type argument
1820         # is mandatory.
1821         # The names are taken from
1822         # the labels of the parameters (se the labels method for specifications of
1823         # default labels) and the values are aquired from the output object bound
1824         # to the model object. If no output exists, the name_val method returns
1825         # undef.
1826         # @name_val will be a two-dimensional array of references to hashes using
1827         # the names from each problem as keys:
1828         # [[ref to hash1 ][ref to hash2][ref to hash3]...]
1829         #
1830         #   $modobj -> name_val( parameter_type => 'theta',
1831         #                        problem_numbers        => [2,4] );
1832         #
1833         # To get matched names and values of specific problems, the problem_numbers argument
1834         # can be used. It should be a reference to an array containing the numbers
1835         # of all problems whos names and values should be retrieved.
1836         #
1837         #   $modobj -> name_val( parameter_type    => 'theta',
1838         #                        problem_numbers           => [2,4],
1839         #                        parameter_numbers => [[1,3][4,6]]);
1840         #
1841         # The retrieval can be even more specific by using the parameter_numbers
1842         # argument. It should be a reference to a two-dimensional array, where
1843         # the inner arrays holds the numbers of the parameters that should be
1844         # fetched. In the example above, parameters one and three from problem two
1845         # plus parameters four and six from problem four are retrieved.
1846         #
1847
1848         unless( $#problem_numbers > 0 ){
1849           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
1850         }
1851         my @names = @{$self -> labels( parameter_type    => $parameter_type,
1852                                        parameter_numbers => \@parameter_numbers,
1853                                        problem_numbers           => \@problem_numbers )};
1854         my @values;
1855         if ( defined $self -> outputs -> [0] ) {
1856           my $accessor  = $parameter_type.'s';
1857           @values = @{$self -> outputs -> [0] ->
1858                         $accessor( problems => \@problem_numbers,
1859                                    parameter_numbers => \@parameter_numbers )};
1860           #       my @problems = @{$self -> {'problems'}};
1861           #       foreach my $i ( @problem_numbers ) {
1862           #         if ( defined $problems[ $i-1 ] ) {
1863           #           my $pn_ref = $#parameter_numbers >= 0 ? \@{$parameter_numbers[ $i-1 ]} : [];
1864           #           push( @names_values,
1865           #                 $problems[ $i-1 ] ->
1866           #                 name_val( parameter_type => $parameter_type,
1867           #                           parameter_numbers => $pn_ref ) );
1868           #         } else {
1869           #           die "Model -> name_val: Problem number $i does not exist!\n";
1870           #         }
1871           #       }
1872         }
1873         #       if ( scalar @{$self -> {'outputs'}} > 0 ) {
1874         #         my $outobj = $self -> {'outputs'} -> [0];
1875         #       }
1876
1877         'debug' -> die( message => "The number of problems retrieved from the model" .
1878                         " do not match the ones retrived from the output" ) unless( $#names == $#values );
1879         for( my $i = 0; $i <= $#names; $i++ ) {
1880           'debug' -> die( message => "Problem " . $i+1 .
1881                           " The number of parameters retrieved from the model (".scalar @{$names[$i]}.
1882                           ") do not match the ones retrived from the output (".
1883                           scalar @{$values[$i][0]}.")" )
1884                           unless( scalar @{$names[$i]} == scalar @{$values[$i][0]} );
1885           my @prob_nv = ();
1886           for( my $j = 0; $j < scalar @{$values[$i]}; $j++ ){
1887             my %nv = ();
1888             for( my $k = 0; $k < scalar @{$names[$i]}; $k++ ){
1889               $nv{$names[$i][$k]} = $values[$i][$j][$k];
1890             }
1891             push( @prob_nv, \%nv );
1892           }
1893           push( @names_values, \@prob_nv );
1894         }
1895       }
1896 end name_val
1897
1898 # }}} name_val
1899
1900 # {{{ nproblems
1901
1902 start nproblems
1903       {
1904         # nproblems returns the number of problems in the modelobject.
1905
1906         $number_of_problem = scalar @{$self -> {'problems'}};
1907       }
1908 end nproblems
1909
1910 # }}} nproblems
1911
1912 # {{{ nthetas
1913
1914 start nthetas
1915       {
1916           # returns the number of thetas in the model for the given
1917           # problem number.
1918         $nthetas = $self -> _parameter_count( 'record' => 'theta', 'problem_number' => $problem_number );
1919       }
1920 end nthetas
1921
1922 # }}} nthetas
1923
1924 # {{{ nomegas
1925
1926 start nomegas
1927       {
1928           # returns the number of omegas in the model for the given
1929           # problem number.
1930 #       $nomegas = $self -> _parameter_count( 'record' => 'omega', 'problem_number' => $problem_number );
1931         unless( $#problem_numbers >= 0 ){
1932           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
1933         }
1934
1935         my @problems = @{$self -> {'problems'}};
1936         foreach my $i ( @problem_numbers ) {
1937           if ( defined $problems[ $i-1 ] ) {
1938             push( @nomegas, $problems[ $i-1 ] -> nomegas );
1939           } else {
1940             'debug' -> die( "Problem number $i does not exist." );
1941           }
1942         }
1943       }
1944 end nomegas
1945
1946 # }}} nomegas
1947
1948 # {{{ nsigmas
1949
1950 start nsigmas
1951
1952 # returns the number of sigmas in the model for the given problem number.
1953
1954 #       $nsigmas = $self -> _parameter_count( 'record' => 'sigma', 'problem_number' => $problem_number );
1955
1956 unless( $#problem_numbers >= 0 ){
1957   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
1958 }
1959
1960 my @problems = @{$self -> {'problems'}};
1961 foreach my $i ( @problem_numbers ) {
1962   if ( defined $problems[ $i-1 ] ) {
1963     push( @nsigmas, $problems[ $i-1 ] -> nsigmas );
1964   } else {
1965     'debug' -> die( "Problem number $i does not exist." );
1966   }
1967 }
1968
1969 end nsigmas
1970
1971 # }}} nsigmas
1972
1973 # {{{ outputfile
1974
1975 start outputfile
1976       {
1977         # Usage:
1978         #
1979         # This method is a (partially) automatically generated accessor for the
1980         # outputfile attribute of the model class. Since no named argument is needed
1981         # for accessors, the two possible ways of calling outputfile are:
1982         #
1983         #   $modelObject -> outputfile( 'newfilename.lst' );
1984         #
1985         #   $outputfilename = $modelObject -> outputfile;
1986         #
1987         # The first alternative sets a new name for the output file, and the second
1988         # retrieves the value.
1989         #
1990         # The extra feature for this accessor, compared to other accessors, is that
1991         # if a new name is given, the accessor tries to create a new output object
1992         # based on this.
1993
1994         if( defined $parm ) {
1995           $self -> {'outputs'} =
1996             [ output ->
1997               new( filename             => $parm,
1998                    ignore_missing_files => $self -> {'ignore_missing_files'},
1999                    target               => $self -> {'target'},
2000                    model_id             => $self -> {'model_id'} ) ];
2001         }
2002       }
2003 end outputfile
2004
2005 # }}} outputfile
2006
2007 # {{{ pk
2008
2009 start pk
2010       {
2011         # sets or gets the pk code for a given problem in the
2012         # model object. The new_pk argument should be an array where
2013         # each element contains a row of a valid NONMEM $PK block,
2014
2015         my @prob = @{$self -> problems};
2016
2017         unless( defined $prob[$problem_number - 1] ){
2018           'debug' -> die( message => "Problem number $problem_number does not exist" );
2019         }
2020
2021         my $pks = $prob[$problem_number - 1] -> pks;
2022         if( scalar @new_pk > 0 ) {
2023           if( defined $pks and scalar @{$pks} > 0 ){
2024             $prob[$problem_number - 1] -> pks -> [0] -> code(\@new_pk);
2025           } else {
2026             'debug' -> die( message => "No \$PK record" );
2027           }
2028         } else {
2029           if ( defined $pks and scalar @{$pks} > 0 ) {
2030             @pk = @{$prob[$problem_number - 1] -> pks -> [0] -> code};
2031           }
2032         }
2033       }
2034 end pk
2035
2036 # }}} pk
2037
2038 # {{{ pred
2039
2040 start pred
2041       {
2042         # Sets or gets the pred code for a given problem in the model
2043         # object. See L</pk> for details.
2044         my @prob = @{$self -> problems};
2045
2046         unless( defined $prob[$problem_number - 1] ){
2047           'debug' -> die( message => "problem number $problem_number does not exist" );
2048         }
2049
2050         if( scalar @new_pred > 0 ) {
2051           if( defined $prob[$problem_number - 1] -> preds ){
2052             $prob[$problem_number - 1] -> preds -> [0] -> code(\@new_pred);
2053           } else {
2054             'debug' -> die( message => "No \$PRED record" );
2055           }
2056         } else {
2057           if ( defined $prob[$problem_number - 1] -> preds ) {
2058             @pred = @{$prob[$problem_number - 1] -> preds -> [0] -> code};
2059           } else {
2060             'debug' -> die( message => "No \$PRED record" );
2061           }
2062         }
2063       }
2064 end pred
2065
2066 # }}} pred
2067
2068 # {{{ print
2069
2070 start print
2071       {
2072         # Prints the formatted model to standard out.
2073
2074         my ( @formatted );
2075         foreach my $problem ( @{$self -> {'problems'}} ) {
2076           push( @formatted, $problem -> format_problem );
2077         }
2078         for ( @formatted ) {
2079           print;
2080         }
2081       }
2082 end print
2083
2084 # }}} print
2085
2086 # {{{ problem_structure
2087
2088 start problem_structure
2089
2090 my ( $val, $pos ) = $self -> _option_val_pos( record_name => 'simulation',
2091                                               name        => 'SUBPROBLEMS' );
2092 if( defined $val ) {
2093   my @vals = @{$val};
2094   for( my $i = 0; $i <= $#vals; $i++ ) {
2095     if( defined $vals[$i] ) {
2096       if( scalar @{$vals[$i]} > 0 ) {
2097         $subproblems[$i] = $vals[$i][0];
2098       } else {
2099         $subproblems[$i] = 1;
2100       }
2101     } else {
2102       $subproblems[$i] = 1;
2103     }
2104   }
2105 }
2106
2107 end problem_structure
2108
2109 # }}} problem_structure
2110
2111 # {{{ randomize_inits
2112
2113 start randomize_inits
2114       {
2115         foreach my $prob ( @{$self -> {'problems'}} ) {
2116           $prob -> set_random_inits ( degree => $degree );
2117         }
2118       }
2119 end randomize_inits
2120
2121 # }}}
2122
2123
2124 # {{{ record
2125
2126 start record
2127      {
2128          # If the argument new_data is given, record sets new_data in
2129          # the model objects member specified with record_name. The
2130          # format of new_data is an array of strings, where each
2131          # element corresponds to a line of code as it would have
2132          # looked like in a valid NONMEM modelfile. If new_data is left
2133          # undefined, record returns lines of code belonging to the
2134          # record specified by record_name in a format that is valid in
2135          # a NONMEM modelfile.
2136
2137          my @problems = @{$self -> {'problems'}};
2138          my $records;
2139
2140          if ( defined $problems[ $problem_number - 1 ] ) {
2141              if ( scalar(@new_data) > 0 ){
2142                  my $rec_class = "model::problem::$record_name";
2143                  my $record = $rec_class -> new('record_arr' => \@new_data );
2144              } else {
2145                  $record_name .= 's';
2146                  $records = $problems[ $problem_number - 1 ] -> {$record_name};
2147                  foreach my $record( @{$records} ){
2148                      push(@data, $record -> _format_record);
2149                  }
2150              }
2151          }
2152      }
2153 end record
2154
2155 # }}} record
2156
2157 # {{{ remove_inits
2158
2159 start remove_inits
2160     {
2161       # Usage
2162       #
2163       # $model -> remove_inits( type => 'theta',
2164       #                         indexes => [1,2,5,6] )
2165       #
2166
2167       # In all cases the type must be set to theta. Removing Omegas in
2168       # Sigmas is not allowed, (If need that feature, send us a
2169       # mail). In the above example the thetas 1, 2, 5 and 6 will be
2170       # removed from the modelfile. Notice that this alters the theta
2171       # numbering, so if you later decide that theta number 7 must be
2172       # removed as well, you must calculate its new position in the
2173       # file. In this case the new number would be 3. Also notice that
2174       # numbering starts with 1.
2175       #
2176       # $model -> remove_inits( type => 'theta',
2177       #                         labels => ['V', 'CL'] )
2178       #
2179
2180       # If you have specified labels in you modelfiles(a label is
2181       # string inside a comment on the same row as the theta) you can
2182       # specify an array with labels, and the corresponding theta, if
2183       # it exists, will be removed. This is a much better approach
2184       # since you don't need to know where in order the theta you wish
2185       # to remove appears. If you specify both labels and indexes, the
2186       # indexes will be ignored.
2187
2188       'debug' -> die( message => 'does not have the functionality for removing $OMEGA or $SIGMA options yet' )
2189           if ( $type eq 'omega' or $type eq 'sigma' );
2190       my $accessor = $type.'s';
2191
2192       # First pick out a referens to the theta records array.
2193       my $inits_ref = $self -> problems -> [$problem_number -1] -> $accessor;
2194
2195       # If we have any thetas at all:
2196       if ( defined $inits_ref ) {
2197         my @inits = @{$inits_ref};
2198
2199         # If labels are specified, we translate the labels into
2200         # indexes.
2201         if ( scalar @labels > 0 ) {
2202           @indexes = ();
2203           my $i = 1;
2204           # Loop over theta records
2205           foreach my $init ( @inits ) {
2206             # Loop over the individual thetas inside
2207             foreach my $option ( @{$init -> options} ) {
2208               # Loop over all given labels.
2209               foreach my $label ( @labels ) {
2210                 # Push the index number if a given label match the
2211                 # theta label
2212                 push( @indexes, $i ) if ( $option -> label eq $label);
2213               }
2214               # $i is the count of thetas so far
2215               $i++;
2216             }
2217           }
2218         }
2219
2220         # We don't really remove thetas, we do a loop over all thetas
2221         # and recording which we like to keep. We do that by selecting
2222         # an index, from @indexes, that shall be removed and loop over
2223         # the thetas, all thetas that doesn't match the index are
2224         # stored in @keep_options. When we find a theta that matches,
2225         # we pick a new index and continue the loop. So by makeing
2226         # sure that @indexes is sorted, we only need to loop over the
2227         # thetas once.
2228
2229         @indexes = sort {$a <=> $b} @indexes;
2230
2231         my $index = 0;
2232         my $nr_options = 1;
2233         my @keep_records;
2234
2235         # Loop over all records
2236         RECORD_LOOP: foreach my $record ( @inits ){
2237           my @keep_options = ();
2238           # Loop over all thetas
2239           foreach my $option ( @{$record -> options} ) {
2240             if( $indexes[ $index ] == $nr_options ){
2241               # If a theta matches an index, we take the next index
2242               # and forget the theta.
2243               unless( $index > $#indexes ){
2244                 $index++;
2245               }
2246             } else {
2247               # Otherwise we rember it.
2248               push(@keep_options,$option);
2249             }
2250             $nr_options++;
2251           }
2252           if( scalar(@keep_options) > 0 ){
2253             # If we remember some thetas, we must also remember the
2254             # record which they are in.
2255             $record -> options( \@keep_options );
2256             push( @keep_records, $record );
2257           }
2258         }
2259
2260         # Set the all kept thetas back into the modelobject.
2261         @{$inits_ref} = @keep_records;
2262
2263       } else {
2264         'debug' -> die( message => "No init of type $type defined" );
2265       }
2266     }
2267 end remove_inits
2268
2269 # }}}
2270
2271 # {{{ restore_inits
2272
2273 start restore_inits
2274       {
2275         # restore_inits brings back initial values previously stored
2276         # using store_inits. This method pair allows a user to store
2277         # the currents initial values in a backup, replace them with
2278         # temporary values and later restore them.
2279
2280         if ( defined $self -> {'problems'} ) {
2281           foreach my $problem ( @{$self -> {'problems'}} ){
2282             $problem -> restore_inits;
2283           }
2284         }
2285       }
2286 end restore_inits
2287
2288 # }}} restore_inits
2289
2290 # {{{ store_inits
2291
2292 start store_inits
2293       {
2294         # store_inits stores initial values that can later be
2295         # brought back using restore_inits. See L</restore_inits>.
2296
2297         if ( defined $self -> {'problems'} ) {
2298           foreach my $problem ( @{$self -> {'problems'}} ){
2299             $problem -> store_inits;
2300           }
2301         }
2302       }
2303 end store_inits
2304
2305 # }}} store_inits
2306
2307 # {{{ synchronize
2308
2309 start synchronize
2310       {
2311           # Synchronize checks the I<synced> object attribute to see
2312           # if the model is in sync with its corresponding file, given
2313           # by the objetc attribute I<filename>. If not, it checks if
2314           # the model contains any defined problems and if it does, it
2315           # writes the formatted model to disk, overwriting any
2316           # existing file of name I<filename>. If no problem is
2317           # defined, synchronize tries to parse the file I<filename>
2318           # and set the object internals to match it.
2319         unless( $self -> {'synced'} ){
2320           if( defined $self -> {'problems'} and
2321               scalar @{$self -> {'problems'}} > 0 ){
2322             $self -> _write;
2323           } else {
2324             if( -e $self -> full_name ){
2325               $self -> _read_problems;
2326             } else {
2327               return;
2328             }
2329           }
2330         }
2331         $self -> {'synced'} = 1;
2332       }
2333 end synchronize
2334
2335 # }}} synchronize
2336
2337 # {{{ flush
2338 start flush
2339       # synchronizes the object with the file on disk and empties
2340       # most of the objects attributes to save memory.
2341       if( defined $self -> {'problems'} and
2342           ( !$self -> {'synced'} or $force ) ) {
2343         $self -> _write;
2344       }
2345       $self -> {'problems'} = undef;
2346       $self -> {'synced'} = 0;
2347
2348 end flush
2349 # }}} flush
2350
2351 # {{{ target
2352 start target
2353       {
2354         if ( $parm eq 'disk' ) {
2355           $self -> {'target'} = 'disk';
2356           $self -> flush;
2357         } elsif ( $parm eq 'mem' and $self -> {'target'} eq 'disk' ) {
2358           $self -> {'target'} = 'mem';
2359           $self -> synchronize;
2360         }
2361       }
2362 end target
2363 # }}}
2364
2365 # {{{ table_names
2366
2367 start table_names
2368       {
2369         # Usage:
2370         #
2371         #    @tableNames = @{$modobj -> table_names};
2372         #
2373         # This basic usage takes no arguments and returns the value of
2374         # the FILE option in the $TABLE NONMEM record of each
2375         # problem. @tableNames will be a two dimensional array:
2376         #
2377         #   [[tableName_prob1][tableName_prob2][tableName_prob3]...]
2378         #
2379         #
2380         # If the I<new_names> argument of table_names is given, the
2381         # values of the FILE options will be changed.
2382         #
2383         # To set the FILE of specific problems, the I<problem_numbers>
2384         # argument can be used. It should be a reference to an array
2385         # containing the numbers of all problems where the FILE should
2386         # be changed or retrieved.  If specified, the size of
2387         # I<new_names> must be the same as the size of
2388         # I<problem_numbers>.
2389         #
2390         # The I<ignore_missing_files> boolean argument can be used to
2391         # set names of table that does not exist yet (e.g. before a
2392         # run has been performed).
2393
2394         my ( $name_ref, $junk ) = $self ->
2395           _option_val_pos( name            => 'FILE',
2396                            record_name     => 'table',
2397                            problem_numbers => \@problem_numbers,
2398                            new_values      => \@new_names );
2399         if ( $#new_names >= 0 ) {
2400           my @problems = @{$self -> {'problems'}};
2401           unless( $#problem_numbers > 0 ){
2402             @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
2403           }
2404           foreach my $i ( @problem_numbers ) {
2405             $problems[$i-1] -> _read_table_files( ignore_missing_files => $ignore_missing_files || $self -> {'ignore_missing_output_files'});
2406           }
2407         }
2408         @names = @{$name_ref};
2409       }
2410 end table_names
2411
2412 # }}} table_names
2413
2414 # {{{ table_files
2415
2416 start table_files
2417       {
2418         # Usage:
2419         #
2420         #    @table_files = @{$modobj -> table_files};
2421         #
2422         # This basic usage takes no arguments and returns the table
2423         # files objects for all problems.  @table_files will be a
2424         # two dimensional array:
2425         #
2426         #   [[table_file_object_prob1][table_file_object_prob2]...]
2427         #
2428         #
2429         # To retrieve the table file objects from specific problems,
2430         # the I<problem_numbers> argument can be used. It should be
2431         # a reference to an array containing the numbers of all
2432         # problems from which the table file objects should be
2433         # retrieved.
2434
2435         unless( $#problem_numbers > 0 ){
2436           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
2437         }
2438         my @problems = @{$self -> {'problems'}};
2439         foreach my $i ( @problem_numbers ) {
2440           if ( defined $problems[ $i-1 ] ) {
2441             push( @table_files, $problems[$i-1] -> table_files );
2442           } else {
2443             'debug' -> die( message => "Problem number $i does not exist!" );
2444           }
2445         }
2446       }
2447 end table_files
2448
2449 # }}}
2450
2451 # {{{ units
2452
2453 start units
2454       {
2455           # Sets or gets the units of a (number of) parameter(s). The
2456           # unit is not a proper NONMEM syntax but is recognized by
2457           # the PsN model class. A unit (and a label) can be specified
2458           # as a comments after a parameter definition. e.g.:
2459           #
2460           #    $THETA (0,13.2,100) ; MTT; h
2461           #
2462           # which will give this theta the label I<MTT> and unit I<h>.
2463         @units = @{ $self -> _init_attr( parameter_type    => $parameter_type,
2464                                          parameter_numbers => \@parameter_numbers,
2465                                          problem_numbers           => \@problem_numbers,
2466                                          new_values        => \@new_values,
2467                                          type              => 'unit')};
2468       }
2469 end units
2470
2471 # }}} units
2472
2473 # {{{ update_inits
2474
2475 start update_inits
2476       {
2477         # Usage:
2478         #
2479         #   $modobj -> update_inits ( from_output => $outobj );
2480         #
2481         # alt
2482         #
2483         #   $modobj -> update_inits ( from_output_file => $outfile );
2484         #
2485         # This basic usage takes the parameter estimates from the
2486         # output object I<$outobj> or from the output file I<$outfile>
2487         # and updates the initial estimates in the model object
2488         # I<$modobj>. The number of problems and parameters must be
2489         # the same in the model and output objects. If there exist
2490         # more than one subproblem per problem in the output object,
2491         # only the estimates from the first subproblem will be
2492         # transferred.
2493         #
2494         #   $modobj -> update_inits ( from_output               => $outobj,
2495         #                             ignore_missing_parameters => 1 );
2496         #
2497         # If the ignore_missing_parameters argument is set to 1, the number of
2498         # parameters in the model and output objects do not need to match. The
2499         # parameters that exist in both objects are used for the update of the
2500         # model object.
2501         #
2502         #   $modobj -> update_inits ( from_output               => $outobj,
2503         #                             from_model                => $from_modobj );
2504         #
2505         # If the from_model argument is given, update_inits tries to match the
2506         # parameter names (labels) given in $from_modobj and $modobj and
2507         # and thereafter updating the $modobj object. See L</units> and L</labels>.
2508         #
2509
2510         my ( %labels, @own_labels, @from_labels );
2511         'debug' -> die( message => "No output object defined and" .
2512                       " no output object found through the model object specified." )
2513             unless ( ( defined $from_model and
2514                        ( defined $from_model -> outputs and
2515                          defined @{$from_model -> outputs}[0] ) ) or
2516                      defined $from_output or
2517                      defined $from_output_file );
2518         if ( defined $from_output ) {
2519           'debug' -> warn( level   => 2,
2520                          message => "using output object ".
2521                          "specified as argument\n" );
2522         } elsif ( defined $from_output_file ) {
2523           $from_output = output -> new( filename             => $from_output_file );
2524         } else {
2525           $from_output = @{$from_model -> outputs}[0];
2526         }
2527
2528         my @params = ();
2529         if( $update_thetas ){
2530           push( @params, 'theta' );
2531         }
2532         if( $update_omegas ) {
2533           push( @params, 'omega' );
2534         }
2535         if( $update_sigmas ) {
2536           push( @params, 'sigma' );
2537         }
2538
2539         foreach my $param ( @params ) {
2540           # Get own labels and from labels
2541           if ( defined $from_model ) {
2542             @own_labels = @{$self -> labels( parameter_type => $param )};
2543
2544             @from_labels = @{$from_model -> labels( parameter_type => $param )};
2545             'debug' -> die( message => "The number of problems are not the same in from-model ".
2546                             $from_model -> full_name." (".
2547                             ($#from_labels+1).")".
2548                             " and the model to be updated ".
2549                             $self -> full_name." (".
2550                             ($#own_labels+1).")" ) unless ( $#own_labels == $#from_labels );
2551           } else {
2552             @own_labels = @{$self -> labels( parameter_type => $param,
2553                                              generic        => 1 )};
2554             @from_labels = @{$from_output -> labels( parameter_type => $param )};
2555             'debug' -> die( message => "The number of problems are not the same in from-output ".
2556                             $from_output -> full_name." (".
2557                             ($#from_labels+1).")".
2558                             " and the model to be updated ".
2559                             $self -> full_name." (".
2560                             ($#own_labels+1).")" ) unless ( $#own_labels == $#from_labels );
2561           }
2562
2563           # Loop over the problems:
2564           my $accessor = $param.'s';
2565           # Since initial estimates are specified on the problem level and not on
2566           # the subproblem level we use the estimates from the outputs first subproblem
2567           my @from_values = @{$from_output -> $accessor ( subproblems => [1] )};
2568           # {{{ Omega and Sigma update section
2569
2570           # The functionality that has been commented out because it
2571           # fails when omegas are zero. This functionality should be
2572           # moved to output::problem::subproblem (2005-02-09) TODO
2573
2574 #         if ($param eq 'omega' or $param eq 'sigma')
2575 #         {
2576 #           #print "FL: ", Dumper @from_labels;
2577 #           #print "OL: ", Dumper @own_labels;
2578 #           print "FV: $param Before " . Dumper(@from_values) . "\n";
2579 #           #Fix omegas and sigmas so that the correlation between elements <=1
2580 #           my $raw_accessor = "raw_" . $accessor;
2581 #           my @raw_from_values = @{$from_output -> $raw_accessor(subproblems => [1])};
2582 #           my ($i,$j);
2583 #           for (my $a=0; $a<scalar(@from_values); $a++)
2584 #           {
2585 #             my $prob_values = $from_values[$a];
2586 #             my $raw_prob_values = $raw_from_values[$a];
2587 #             for (my $b=0; $b<scalar(@{$prob_values}); $b++)
2588 #             {
2589 #               my $values = $prob_values->[$b];
2590 #               my $raw_values = $raw_prob_values->[$b];
2591 #               my $counter = 0;
2592 #               #Find out the n*n-matrix size (pq-formula)
2593 #               my $n = int(sqrt(1/4+scalar(@{$raw_values})*2)-1/2);
2594 #               for ($i=0; $i<$n; $i++)
2595 #               {
2596 #                 for ($j=0; $j<$n; $j++)
2597 #                 {
2598 #                   if ( $j<=$i && $raw_values->[$i*($i+1)/2+$j]!=0 )
2599 #                   {
2600 #                     #print "Omega value = " . @other_val[$counter]  . "\n";
2601 #                     $counter++;
2602 #                   }
2603 #                   #Only check the low-triangular off-diagonals of the omega matrix
2604 #                   #omega(i,j)>=sqrt(omega(i,i)*omega(j,j))
2605 #                   if ($j<=$i && $j!=$i &&
2606 #                       ($raw_values->[$i*($i+1)/2+$j]>=sqrt(
2607 #                                                            $raw_values->[$i*($i+1)/2+$i]*$raw_values->[$j*($j+1)/2+$j])))
2608 #                   {
2609 #                     print "Changing raw value at $i, $j: " . $raw_values->[$i*($i+1)/2+$j] ." to ".
2610 #                         (int(10000*sqrt($raw_values->[$i*($i+1)/2+$i]*$raw_values->[$j*($j+1)/2+$j]))/10000) ."\n";
2611 #                     #print "At index ($i,$j)\n" if ($self->{'debug'});
2612 #                     $raw_values->[$i*($i+1)/2+$j]=int(10000*sqrt(
2613 #                                                                  $raw_values->[$i*($i+1)/2+$i]*$raw_values->[$j*($j+1)/2+$j]))/10000;
2614 #                     print "Changing omega value " . $values->[$counter-1] . " to " . $raw_values->[$i*($i+1)/2+$j] ."\n";
2615 #                     $values->[$counter-1] = $raw_values->[$i*($i+1)/2+$j];
2616 #                   }
2617 #                 }
2618 #               }
2619 #             }
2620 #           }
2621 #           #print "FL: ", Dumper @from_labels;
2622 #           #print "OL: ", Dumper @own_labels;
2623 #           print "FV: $param After ", Dumper(@from_values), "\n";
2624 #           die;
2625 #         }
2626
2627           # }}}
2628
2629           for ( my $i = 0; $i <= $#own_labels; $i++ ) {
2630             unless ( $ignore_missing_parameters ) {
2631               my $from_name = defined $from_model ? $from_model -> filename :
2632                 $from_output -> filename;
2633               'debug' -> die( message => "Model -> update_inits: The number of ".$param.
2634                               "s are not the same in from-model (" . $from_name .
2635                               "): " . scalar @{$from_labels[$i]} .
2636                               ", and the model to be updated (" . $self -> {'filename'} .
2637                               "): " . scalar @{$own_labels[$i]} )
2638                   unless ( scalar @{$own_labels[$i]} ==
2639                            scalar @{$from_labels[$i]} );
2640             }
2641
2642             for ( my $j = 0; $j < scalar @{$from_labels[$i]}; $j++ ) {
2643               for ( my $k = 0; $k < scalar @{$own_labels[$i]}; $k++ ) {
2644                 if ( $from_labels[$i][$j] eq $own_labels[$i][$k] ){
2645                   $labels{$k+1} = $from_values[$i][0][$j];
2646                 }
2647               }
2648             }
2649
2650             my @own_idxs = keys( %labels );
2651             my @from_vals;
2652             for(my $i=0; $i <= $#own_idxs; $i++){
2653               @from_vals[$i] = $labels{ $own_idxs[$i] };
2654             }
2655
2656             $self -> initial_values( problem_numbers           => [$i+1],
2657                                      parameter_type    => $param,
2658                                      parameter_numbers => [\@own_idxs],
2659                                      new_values        => [\@from_vals] );
2660           }
2661         }
2662       }
2663 end update_inits
2664
2665 # }}} update_inits
2666
2667 # {{{ upper_bounds
2668
2669 start upper_bounds
2670       {
2671         # upper_bounds either sets or gets the initial values of the
2672         # parameter specified in I<parameter_type> for each
2673         # subproblem specified in I<problem_numbers>. For each
2674         # element in I<problem_numbers> there must be an array in
2675         # I<parameter_numbers> that specify the indices of the
2676         # parameters in the subproblem for which the upper bounds
2677         # are set, replaced or retrieved.
2678
2679         @upper_bounds = @{ $self -> _init_attr
2680                              ( parameter_type    => $parameter_type,
2681                                parameter_numbers => \@parameter_numbers,
2682                                problem_numbers           => \@problem_numbers,
2683                                new_values        => \@new_values,
2684                                attribute         => 'upbnd')};
2685       }
2686 end upper_bounds
2687
2688 # }}} upper_bounds
2689
2690 # {{{ clean_extra_data_code
2691 start clean_extra_data_code
2692     {
2693
2694       # This method cleans out old code for extra data. It searches
2695       # all subroutine statements in all problems for external
2696       # subroutines named "get_sub" and "reader" which are added by
2697       # "add_extra_data_code".
2698
2699       foreach my $problem( @{$self -> {'problems'}} ){
2700         if ( defined $problem -> subroutines and defined $problem -> subroutines -> [0] -> options) {
2701           foreach my $option ( @{$problem -> subroutines -> [0] -> options} ){
2702             if( lc($option -> name) eq 'other'){
2703               if( lc($option -> value) =~ /get_sub|reader/  ){
2704
2705                 # If we find "get_sub" or "reader" we remove
2706                 # everything between "IMPORTING COVARIATE DATA" and
2707                 # "IMPORTING COVARIATE DATA END" by finding the
2708                 # indexes in the code array and and splicing it out.
2709
2710                 my $code;
2711                 if( $problem -> pks ){
2712                   # If the code is in a pk block:
2713                   $code = $problem -> pks -> [0] -> code;
2714                 } else {
2715                   $code = $problem -> preds -> [0] -> code;
2716                 }
2717
2718                 my $start_idx;
2719                 my $end_idx;
2720                 for( my $i = 0; $i <= $#{$code}; $i++ ){
2721                   if( $code -> [$i] eq ";***IMPORTING COVARIATE DATA*******\n" ){
2722                     $start_idx = $i-1;
2723                   }
2724                   if( $code -> [$i] eq ";***IMPORTING COVARIATE DATA END***\n" ){
2725                     $end_idx = $i+1;
2726                   }
2727                 }
2728                 @{$code} = ( @{$code}[0..$start_idx] , @{$code}[$end_idx..$#{$code}] );
2729
2730                 if( $problem -> pks ){
2731                   # Put the cut down code back in the right place:
2732                   $problem -> pks -> [0] -> code( $code );
2733                 } else {
2734                   $problem -> preds -> [0] -> code( $code );
2735                 }
2736
2737                 last;
2738               }
2739             }
2740           }
2741         }
2742       }
2743     }
2744 end clean_extra_data_code
2745 # }}} clean_extra_data_code
2746
2747 # {{{ add_extra_data_code
2748
2749 start add_extra_data_code
2750       {
2751       # This method adds fortran code that will handle wide datasets
2752       # (that is data sets with more than 20 columns). It adds code to
2753       # each problems pk or pred.
2754
2755       my @code_lines;
2756
2757       # Get the headers of the columns that have been moved to another
2758       # data file.
2759
2760 #      unless( defined $self -> extra_data_headers ){
2761 #       die "ERROR model::add_extra_data_code: No headers for the extra data file\n";
2762 #      }
2763
2764       # extra_data_headers is a two dimensional array. One array of
2765       # headers for each problem in the modelfile.
2766       for( my $i = 0; $i <= $#{$self -> {'problems'}}; $i++ ){
2767         if ( defined $self -> {'problems'} -> [$i] -> {'extra_data_header'} ) {
2768           my $problem_headers = $self -> {'problems'} -> [$i] -> {'extra_data_header'};
2769
2770           my $length = 0;
2771           my @headers;
2772           my $header_string;
2773           # Loop over the problem specific headers and make a string
2774           # that will go into the fortran code. Assume that the
2775           # first column holds the ID, hence the $i=1
2776           for (my $i = 1; $i <= $#{$problem_headers}; $i++ ) {
2777             my $header = $problem_headers -> [$i];
2778             push( @headers, $header );
2779             # Chopp the string at 40 characters, to be nice to g77 :)
2780             if ( $length + length($header) > 40 ) {
2781               $header_string .= "\n\"&  ";
2782               $length = 0
2783             }
2784             if ( $i < $#{$problem_headers} ) {
2785               $header_string .= 'I' . $header . ', ';
2786               $length += length( 'I' . $header . ', ' );
2787             } else {
2788               $header_string .= 'I' . $header;
2789               $length += length( 'I' . $header );
2790             }
2791           }
2792
2793           my @code_lines = ('',
2794                             ';***IMPORTING COVARIATE DATA*******',
2795                             '"  FIRST',
2796                             '"  REAL CURID, MID,',
2797                             '"&  '.$header_string,
2798                             '"  LOGICAL READ',
2799                             '"',
2800                             '"  IF (.NOT.READ) THEN',
2801                             '"    CALL READER()',
2802                             '"    CURID = 1',
2803                             '"    READ = .TRUE.',
2804                             '"    END IF',
2805                             '"',
2806                             '"  IF (NEWIND.LT.2) THEN',
2807                             '"    CALL GET_SUB (NEWIND,ID,CURID,MID,',
2808                             '"&  '.$header_string. ')',
2809                             '"  END IF',
2810                             '  CID = MID',
2811                             '  IF (CID.NE.ID) THEN',
2812                             '    PRINT *, \'ERROR CHECKING FAILED, CID = \', CID ,\' ID = \', ID',
2813                             '  END IF',
2814                             '');
2815
2816           foreach my $header ( @headers ) {
2817             push( @code_lines, "  $header = I$header" );
2818           }
2819
2820           push( @code_lines, (';***IMPORTING COVARIATE DATA END***','','') );
2821
2822           my $problem = $self -> {'problems'} -> [$i];
2823           if ( defined $problem -> {'subroutines'} ) {
2824             $problem -> subroutines -> [0] -> _add_option( option_string => 'OTHER=get_sub' . $i );
2825             $problem -> subroutines -> [0] -> _add_option( option_string => 'OTHER=reader' . $i );
2826           } else {
2827             $problem -> add_records( type => 'subroutines', record_strings => ['OTHER=get_sub', 'OTHER=reader'] );
2828           }
2829
2830           if ( defined $problem -> pks ) {
2831             unshift( @{$problem -> pks -> [0] -> code}, join("\n", @code_lines ));
2832           } else {
2833             unshift( @{$problem -> preds -> [0] -> code},join("\n", @code_lines ));
2834           }
2835         }
2836       }
2837     }
2838 end add_extra_data_code
2839
2840 # }}}
2841
2842 # {{{ drop_dropped
2843
2844 start drop_dropped
2845       {
2846         for( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
2847           $self -> {'datas'}[$i] -> drop_dropped( model_header => $self -> {'problems'}[$i] -> header );
2848           $self -> {'problems'}[$i] -> drop_dropped( );
2849           #$self -> {'datas'}[$i] -> model_header( $self -> {'problems'}[$i] -> header );
2850         }
2851       }
2852 end drop_dropped
2853
2854 # }}} drop_dropped
2855
2856 # {{{ wrap_data
2857
2858 start wrap_data
2859       {
2860         my $default_wrap = 18;
2861
2862         my ( @wrap_columns, @cont_columns );
2863         if ( not defined $wrap_column ) {
2864           for( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
2865             my $columns = scalar @{$self -> {'problems'}[$i] -> dropped_columns}-1; #skip ID
2866             my $modulus = $columns%($default_wrap-2); # default_wrap-2 to account for ID and CONT
2867             my $rows = (($columns-$modulus)/($default_wrap-2))+1;
2868             if ( $rows == 1 ) {
2869               push( @wrap_columns, undef );
2870             } else {
2871               push( @wrap_columns, (ceil( $columns/$rows )+2) ); #Must use #cols + ID and CONT
2872             }
2873           }
2874         } else {
2875           for( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
2876             push( @wrap_columns, $wrap_column );
2877           }
2878         }
2879
2880         for( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
2881           next if ( not defined $wrap_columns[$i] );
2882           $wrap_column = $wrap_columns[$i];
2883           $cont_column = $wrap_columns[$i] if( not defined $cont_column );
2884           my ( $prim, $sec ) =
2885             $self -> {'datas'}[$i] -> wrap( cont_column  => $cont_column,
2886                                             wrap_column  => $wrap_column,
2887                                             model_header => $self -> {'problems'}[$i] -> header );
2888           $self -> {'problems'}[$i] -> primary_columns( $prim );
2889           $self -> {'problems'}[$i] -> secondary_columns( $sec );
2890           $self -> {'data_wrapped'}++;
2891         }
2892       }
2893 end wrap_data
2894
2895 # }}} wrap_data
2896
2897 # {{{ unwrap_data
2898 start unwrap_data
2899       {
2900         for( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
2901           $self -> {'datas'}[$i] -> unwrap;
2902           $self -> {'problems'}[$i] -> primary_columns( [] );
2903           $self -> {'problems'}[$i] -> secondary_columns( [] );
2904         }
2905         $self -> {'data_wrapped'} = 0;
2906       }
2907 end unwrap_data
2908 # }}} unwrap_data
2909
2910 # {{{ write_get_subs
2911
2912 start write_get_subs
2913     {
2914       for( my $i = 0; $i <= $#{$self -> {'problems'}}; $i++ ){
2915         if ( defined $self -> {'problems'} -> [$i] -> {'extra_data_header'} and
2916              defined $self -> problems -> [$i] -> extra_data ) {
2917           my @problem_header = @{$self -> {'problems'} -> [$i] -> {'extra_data_header'}};
2918           my @headers;
2919           my $length = 0;
2920           my $header_string;
2921
2922           my $rows = $self -> problems -> [$i] -> extra_data -> count_ind;
2923
2924           # Assume that first column holds the ID. Get rid of it.
2925           shift( @problem_header );
2926           for ( my $i = 0; $i <= $#problem_header; $i++ ) {
2927             my $header = $problem_header[$i];
2928             push( @headers, $header );
2929             # Chop the string at 40 characters, to be nice to g77 :)
2930             if ( $length + length($header) > 40 ) {
2931               $header_string .= "\n     &  ";
2932               $length = 0
2933             }
2934             if ( $i < $#problem_header ) {
2935               $header_string .= $header . ', ';
2936               $length += length( $header . ', ' );
2937             } else {
2938               $header_string .= $header;
2939               $length += length( $header );
2940             }
2941           }
2942
2943           open( FILE, '>', 'get_sub' . $i . '.f' );
2944           print FILE ("      SUBROUTINE GET_SUB (NEWIND,ID,CURID,MID,\n",
2945                       "     &  $header_string)\n",
2946                       "      COMMON /READ/ TID,TCOV\n",
2947                       "\n",
2948                       "      REAL ID,CURID,MID,\n",
2949                       "     &  $header_string\n",
2950                       "\n",
2951                       "      INTEGER NEWIND\n",
2952                       "\n",
2953                       "      REAL TID($rows), TCOV($rows,",scalar @problem_header,")\n",
2954                       "      CURID = 1\n",
2955                       "\n",
2956                       "C     START AT TOP EVERY TIME\n",
2957                       "      IF (NEWIND.EQ.1) THEN \n",
2958                       "12      CONTINUE\n",
2959                       "        IF (CURID.GT.$rows) THEN \n",
2960                       "          PRINT *, \"Covariate data not found for\", ID\n",
2961                       "          MID = -9999\n",
2962                       "          RETURN\n",
2963                       "        END IF\n",
2964                       "\n",
2965                       "        IF (ID.GT.TID (CURID)) THEN\n",
2966                       "          CURID = CURID + 1\n",
2967                       "          GOTO 12\n",
2968                       "        END IF\n",
2969                       "      ELSEIF (NEWIND.EQ.0) THEN\n",
2970                       "        CURID = 1\n",
2971                       "      END IF\n",
2972                       "\n" );
2973           my $length = 0;
2974           for ( my $i = 1; $i <= $#headers+1; $i++ ) {
2975             $length += length("TCOV(I,$i),");
2976             if ( $length > 40 ) {
2977               print FILE "\n";
2978               $length = 0;
2979             }
2980             print FILE "      ".$headers[$i-1] . "  = TCOV(CURID,$i)\n";
2981           }
2982
2983           print FILE ("      MID  = TID(CURID)\n",
2984                       "      END\n",
2985                       "\n" );
2986
2987           close FILE;
2988         }
2989       }
2990       close( FILE );
2991     }
2992 end write_get_subs
2993
2994 # }}}
2995
2996 # {{{ write_readers
2997
2998 start write_readers
2999     {
3000       for( my $i = 0; $i <= $#{$self -> {'problems'}}; $i++ ){
3001         if ( defined $self -> {'problems'} -> [$i] -> {'extra_data_header'} and
3002              defined $self -> {'problems'} -> [$i] -> {'extra_data'} ) {
3003           my @problem_header = @{$self -> {'problems'} -> [$i] -> {'extra_data_header'}};
3004           my @headers;
3005           my $length = 0;
3006
3007           my $rows = $self -> problems -> [$i] -> extra_data -> count_ind;
3008           my $filename = $self -> problems -> [$i] -> extra_data -> filename;
3009           # Assume that first column holds the ID. Get rid of it.
3010           shift( @problem_header );
3011
3012           'debug' -> warn( level   => 2,
3013                            message => "Writing reader".$i.".f to directory".cwd );
3014           open( FILE, '>', 'reader' . $i . '.f' );
3015           print FILE ("      SUBROUTINE READER()\n",
3016                       "\n",
3017                       "      COMMON /READ/ TID,TCOV\n",
3018                       "\n",
3019                       "      REAL TID ($rows), TCOV ($rows, ",scalar @problem_header,")\n",
3020                       "\n",
3021                       "      OPEN (UNIT = 77,FILE = '$filename')\n",
3022                       "      REWIND 77\n",
3023                       "      DO 11,I = 1,$rows\n",
3024                       "        READ (77,*) TID(I)," );
3025
3026           my $length = 0;
3027           for ( my $i = 1; $i <= $#problem_header+1; $i++ ) {
3028             $length += length("TCOV(I,$i),");
3029             if ( $length > 40 ) {
3030               print FILE "\n     &  ";
3031               $length = 0;
3032             }
3033             if ( $i <= $#problem_header ) {
3034               print FILE "TCOV(I,$i),";
3035             } else {
3036               print FILE "TCOV(I,$i)\n";
3037             }
3038           }
3039
3040           print FILE ( "11      CONTINUE\n",
3041                        "      END\n" );
3042         }
3043       }
3044     }
3045 end write_readers
3046
3047 # }}}
3048
3049 # {{{ _write
3050
3051 start _write
3052       {
3053         #
3054         # $model -> _write( filename => 'model.mod' );
3055         #
3056         # Writes the content of the modelobject to disk. Either to the
3057         # filename given, or to the string returned by model::full_name.
3058
3059         my @formatted;
3060
3061         # An element in the active_problems array is a boolean that
3062         # corresponds to the element with the same index in the problems
3063         # array.  If the boolean is true, the problem will be run. All
3064         # other will be commented out.
3065         my @active = @{$self -> {'active_problems'}};
3066
3067         # loop over all problems.
3068         for ( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
3069           # Call on the problem object to format it as text. The
3070           # filename and problem numbers are needed to make some
3071           # autogenerated files (msfi, tabels etc...) unique to the
3072           # model and problem
3073           my @preformatted = @{$self -> {'problems'} -> [$i] ->
3074 #                                  _format_problem };
3075                                    _format_problem( filename => $self -> filename,
3076                                                     problem_number => ($i+1) ) };
3077           # Check if the problem is NOT active, if so comment it out.
3078           unless ( $active[$i] ) {
3079             for ( my $j = 0; $j <= $#preformatted; $j++ ) {
3080               $preformatted[$j] = '; '.$preformatted[$j];
3081             }
3082           }
3083           # Add extra line to avoid problems with execution of NONMEM
3084           push(@preformatted,"\n");
3085           push( @formatted, @preformatted );
3086         }
3087
3088         # Open a file and print the formatted problems.
3089         # TODO Add some errorchecking.
3090         open( FILE, '>'. $filename );
3091         for ( @formatted ) {
3092           chomp;
3093           print FILE;
3094           print FILE "\n";
3095         }
3096         close( FILE );
3097
3098         if ( $write_data ) {
3099           foreach my $data ( @{$self -> {'datas'}} ) {
3100             $data -> _write;
3101           }
3102         }
3103       }
3104 end _write
3105
3106 # }}} _write
3107
3108 # {{{ filename
3109 start filename
3110       {
3111         if ( defined $parm and $parm ne $self -> {'filename'} ) {
3112           $self -> {'filename'} = $parm;
3113           $self -> {'model_id'} = undef;
3114 #         $self -> _write;
3115         }
3116       }
3117 end filename
3118 # }}} filename
3119
3120 # {{{ _get_option_val_pos
3121
3122 start _get_option_val_pos
3123       {
3124         # Usage:
3125         #
3126         #   ( $values_ref, $positions_ref ) ->
3127         #               _get_option_val_pos ( name        => 'ID',
3128         #                                     record_name => 'input' );
3129         #   my @values = @{$values_ref};
3130         #   my @positions = @{$positions_ref};
3131         #
3132         # This basic usage returns the name of the third option in the first
3133         # instance of the record specified by I<record_name> for all problems
3134         #
3135         # If global_position is set to 1, only one value and position
3136         # pair is returned per problem. If there are more than one
3137         # match in the model; the first will be returned for each
3138         # problem.
3139         #
3140         # Private method, should preferably not be used outside model.pm
3141
3142 #       my ( @records, @instances );
3143         my $accessor = $record_name.'s';
3144         my @problems = @{$self -> {'problems'}};
3145         unless( $#problem_numbers > 0 ){
3146           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
3147         }
3148         foreach my $i ( @problem_numbers ) {
3149           my $rec_ref = $problems[ $i-1 ] -> $accessor;
3150           if ( defined $problems[ $i-1 ] and defined $rec_ref ) {
3151             my @records = @{$rec_ref};
3152             unless( $#instances > 0 ){
3153               @instances = (1 .. $#records+1);
3154
3155             }
3156             my @inst_values    = ();
3157             my @inst_positions = ();
3158             my $glob_pos = 1;
3159             my ( $glob_value, $glob_position );
3160 INSTANCES:  foreach my $j ( @instances ) {
3161               if ( defined $records[ $j-1 ] ) {
3162                 my $k = 1;
3163                 my ( $value, $position );
3164                 foreach my $option ( @{$records[$j-1] -> {'options'}} ) {
3165                   if ( defined $option and $option -> name eq $name) {
3166                     if ( $global_position ) {
3167                       $glob_value = $option -> value;
3168                       $glob_position = $glob_pos;
3169                       last INSTANCES;
3170                     } else {
3171                       $value = $option -> value;
3172                       $position = $k;
3173                     }
3174                   }
3175                   $k++;
3176                   $glob_pos++;
3177                 }
3178                 push( @inst_values, $value );
3179                 push( @inst_positions, $position );
3180               } else {
3181                 'debug' -> die( message => "Instance $j in problem number $i does not exist!" )
3182               }
3183             }
3184             if ( $global_position ) {
3185               push( @values, $glob_value );
3186               push( @positions, $glob_position );
3187             } else {
3188               push( @values, \@inst_values );
3189               push( @positions, \@inst_positions );
3190             }
3191           } else {
3192             'debug' -> die( message => "Problem number $i does not exist!" );
3193           }
3194         }
3195 #       if( defined $problem_number ) {
3196 #         if( $problem_number < 1 or $problem_number > scalar @problems ) {
3197 #           die "model -> _get_option_val_pos: No such problem number, ",
3198 #             $problem_number,", in this model!\n";
3199 #         }
3200 #       }
3201 #       my $i;
3202 #       die "modelfile -> _get_option_val_pos: No problem $problem_number exists\n"
3203 #         if( (scalar @problems < 1) and ($problem_number ne 'all') );
3204 #       my $j = 1;
3205 #       foreach my $problem ( @problems ) {
3206 #         @records = @{$problem -> $accessor};
3207 #         @records = ($records[$instance-1]) if ( $instance ne 'all' );
3208 #         die "modelfile -> _get_option_val_pos: No record instance $instance ".
3209 #           "of record $record_name in problem $problem_number exists\n"
3210 #             if( (scalar @records < 1) and ($instance ne 'all') );
3211 #         foreach my $record ( @records ) {
3212 #           $i = 1;
3213 #           foreach my $option ( @{$record -> {'options'}} ) {
3214 #             if ( defined $option and $option -> name eq $name) {
3215 #               print "Found $name at $i\n" if ( $self -> {'debug'} );
3216 #               push( @values, $option -> value );
3217 #               push( @positions, $i );
3218 #             }
3219 #             $i++;
3220 #           }
3221 #         }
3222 #       }
3223       }
3224 end _get_option_val_pos
3225
3226 # }}} _get_option_val_pos
3227
3228 # {{{ _init_attr
3229
3230 start _init_attr
3231       {
3232         # The I<add_if_absent> argument tells the method to add an init (theta,omega,sigma)
3233         # if the parameter number points to a non-existing parameter with parameter number
3234         # one higher than the highest presently included. Only applicatble if
3235         # I<new_values> are set. Default value = 0;
3236
3237         unless( scalar @problem_numbers > 0 ){
3238           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
3239         }
3240         my @problems = @{$self -> {'problems'}};
3241         if ( $#new_values >= 0 ) {
3242           'debug' -> die( message => "The number of new value sets " .
3243                           $#new_values+1 . " do not" .
3244                           " match the number of problems " . $#problem_numbers+1 . " specified" )
3245               unless(($#new_values == $#problem_numbers) );
3246           if ( $#parameter_numbers > 0 ) {
3247             'debug' -> die( message => "The number of parameter number sets do not" .
3248                             " match the number of problems specified" )
3249                 unless(($#parameter_numbers == $#problem_numbers) );
3250           }
3251         }
3252
3253         my $new_val_idx = 0;
3254         foreach my $i ( @problem_numbers ) {
3255           if ( defined $problems[ $i-1 ] ) {
3256             if ( scalar @new_values > 0) {
3257               # {{{ Update values
3258               # Use attribute parameter_values to collect diagnostic outputs
3259               push( @parameter_values,
3260                     $problems[ $i-1 ] ->
3261                     _init_attr( parameter_type    => $parameter_type,
3262                                 parameter_numbers => $parameter_numbers[ $new_val_idx ],
3263                                 new_values        => \@{$new_values[ $new_val_idx ]},
3264                                 attribute         => $attribute,
3265                                 add_if_absent     => $add_if_absent ) );
3266               # }}} Update values
3267             } else {
3268               # {{{ Retrieve values
3269               push( @parameter_values,
3270                     $problems[ $i-1 ] ->
3271                     _init_attr( parameter_type    => $parameter_type,
3272                                 parameter_numbers => $parameter_numbers[ $i-1 ],
3273                                 attribute         => $attribute ) );
3274               # }}} Retrieve values
3275             }
3276           } else {
3277             'debug' -> die( message => "Problem number $i does not exist!" );
3278           }
3279           $new_val_idx++;
3280         }
3281       }
3282 end _init_attr
3283
3284 # }}} _init_attr
3285
3286 # {{{ _option_name
3287
3288 start _option_name
3289       {
3290         # Usage:
3291         #
3292         #   $modobj -> _option_name ( record   => $record_name,
3293         #                             position => 3 );
3294         #
3295         # This basic usage returns the name of the third option in the first
3296         # instance of the record specified by I<record>.
3297         #
3298
3299         my ( @problems, @records, @options, $i );
3300         my $accessor = $record.'s';
3301         if ( defined $self -> {'problems'} ) {
3302           @problems = @{$self -> {'problems'}};
3303         } else {
3304           'debug' -> die( message => "No problems defined in model" );
3305         }
3306         if ( defined $problems[$problem_number - 1] -> $accessor ) {
3307           @records = @{$problems[$problem_number - 1] -> $accessor};
3308         } else {
3309           'debug' -> die( message => "No record $record defined in ".
3310                           "problem number $problem_number." );
3311         }
3312         if ( defined $records[$instance - 1] -> options ) {
3313           @options = @{$records[$instance - 1] -> options};
3314         } else {
3315           'debug' -> die( message => "model -> _option_name: No option defined in record ".
3316                           "$record in problem number $problem_number." );
3317         }
3318         $i = 0;
3319         foreach my $option ( @options ) {
3320           if ( $i == $position ) {
3321             if ( defined $new_name ){
3322               $option -> name($new_name) if ( defined $option );
3323             }else{
3324               $name = $option -> name if ( defined $option );
3325             }
3326           }
3327           $i++;
3328         }
3329       }
3330 end _option_name
3331
3332 # }}} _option_name
3333
3334 # {{{ _parameter_count
3335 start _parameter_count
3336       {
3337         if( defined $self -> {'problems'} ){
3338           my $problems = $self -> {'problems'};
3339           if( defined @{$problems}[$problem_number - 1] ){
3340             $count = @{$problems}[$problem_number - 1] -> record_count( 'record_name' => $record );
3341           }
3342         }
3343       }
3344 end _parameter_count
3345 # }}} _parameter_count
3346
3347 # {{{ _read_problems
3348
3349 start _read_problems
3350     {
3351
3352       # To read problems from a modelfile we need its full name
3353       # (meaning filename and path). And we need an array for the
3354       # modelfile lines and an array with indexes telling where
3355       # problems start in the modelfile array.
3356
3357
3358       my $file = $self -> full_name;
3359       my ( @modelfile, @problems );
3360       my ( @problem_start_index );
3361
3362       # Check if the file is missing, and if that is ok.
3363       # TODO Check accessor what happens if the file is missing.
3364
3365       return if( not (-e $file) && $self -> {'ignore_missing_files'} );
3366
3367       # Open the file, slurp it and close it
3368       open( FILE, "$file" ) ||
3369           'debug' -> die( message => "Model -> _read_problems: Could not open $file".
3370                         " for reading" );
3371       @modelfile = <FILE>;
3372       close( FILE );
3373
3374       my @extra_data_files   = defined $self ->{'extra_data_files'} ?
3375           @{$self -> {'extra_data_files'}} : ();
3376       my @extra_data_headers = defined $self ->{'extra_data_headers'} ?
3377           @{$self -> {'extra_data_headers'}} : ();
3378
3379
3380 #       # Find the indexes where the problems start
3381 #       for ( my $i = 0; $i <= $#modelfile; $i++ ) {
3382 #       push( @problem_start_index, $i )if ( $modelfile[$i] =~ /\$PROB/ );
3383 #       }
3384
3385 #       # Loop over the number of problems. Copy the each problems lines
3386 #       # and create a problem object.
3387
3388 #       for( my $i = 0; $i <= $#problem_start_index; $i++ ) {
3389 #       my $start_index = $problem_start_index[$i];
3390 #       my $end_index = defined $problem_start_index[$i+1] ? $problem_start_index[$i+1] - 1: $#modelfile ;
3391 #       # Line copy
3392 #       my @problem_lines = @modelfile[$start_index .. $end_index];
3393
3394 #       # Problem object creation.
3395 #       push( @problems, model::problem -> new ( debug                => $self -> {'debug'},
3396 #                                                ignore_missing_files => $self -> {'ignore_missing_files'},
3397 #                                                prob_arr             => \@problem_lines,
3398 #                                                extra_data_file_name => $extra_data_files[$i],
3399 #                                                extra_data_header    => $extra_data_headers[$i]) );
3400
3401       my $start_index = 0;
3402       my $end_index;
3403       my $first = 1;
3404       my $prob_num = 0;
3405
3406       # It may look like the loop takes one step to much, but its a
3407       # trick that helps parsing the last problem.
3408       for ( my $i = 0; $i <= @modelfile; $i++ ) {
3409         if( $i <= $#modelfile ){
3410           $_ = $modelfile[$i];
3411         }
3412
3413         # In this if statement we use the lazy evaluation of logical
3414         # or to make sure we only execute search pattern when we have
3415         # a line to search. Which is all cases but the very last loop
3416         # iteration.
3417
3418         if( $i > $#modelfile or /\$PROB/ ){
3419           $end_index = $i;
3420
3421           # The if statement here is only necessary in the first loop
3422           # iteration. When start_index == end_index == 0 we want to
3423           # skip to the next iteration looking for the actual end of
3424           # the first problem.
3425
3426           if( $end_index > $start_index and not $first ){
3427             # extract lines of code:
3428             my @problem_lines = @modelfile[$start_index .. $end_index-1];
3429             # reset the search for problems by moving the problem start
3430             # forwards:
3431             $start_index = $i;
3432
3433             my $sh_mod = new model::shrinkage_module( model   => $self,
3434                                                       temp_problem_number => ($#problems+2));
3435             push( @problems, model::problem ->
3436                   new ( directory                   => $self -> {'directory'},
3437                         ignore_missing_files        => $self -> {'ignore_missing_files'},
3438                         ignore_missing_output_files => $self -> {'ignore_missing_output_files'},
3439                         sde                         => $self -> {'sde'},
3440                         prob_arr                    => \@problem_lines,
3441                         extra_data_file_name        => $extra_data_files[$prob_num],
3442                         extra_data_header           => $extra_data_headers[$prob_num],
3443                         shrinkage_module            => $sh_mod ) );
3444
3445             $sh_mod -> problem( $problems[$#problems] );
3446             $prob_num++;
3447           }
3448           $first = 0;
3449         }
3450       }
3451
3452       # Set the problems in the modelobject.
3453       $self -> problems(\@problems);
3454     }
3455 end _read_problems
3456
3457 # }}} _read_problems
3458
3459 # {{{ set_option
3460
3461 start set_option
3462
3463 unless( $#problem_numbers >= 0 ){
3464   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
3465 }
3466
3467 my @problems = @{$self -> {'problems'}};
3468 foreach my $i ( @problem_numbers ) {
3469   if ( defined $problems[ $i-1 ] ) {
3470     my $found = $self -> is_option_set( 'problem_number' => $i,
3471                                         'record'         => $record_name,
3472                                         'name'           => $option_name );
3473     $problems[$i-1] -> remove_option( record_name  => $record_name,
3474                                       option_name  => $option_name ) if ( $found );
3475     $problems[$i-1] -> add_option( record_name  => $record_name,
3476                                    option_name  => $option_name,
3477                                    option_value => $option_value );
3478   }
3479 }
3480
3481 end set_option
3482
3483 # }}} set_option
3484
3485 # {{{ add_option
3486
3487 start add_option
3488
3489 unless( $#problem_numbers >= 0 ){
3490   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
3491 }
3492
3493 my @problems = @{$self -> {'problems'}};
3494 foreach my $i ( @problem_numbers ) {
3495   if ( defined $problems[ $i-1 ] ) {
3496     $problems[$i-1] -> add_option( record_name  => $record_name,
3497                                    option_name  => $option_name,
3498                                    option_value => $option_value,
3499                                    add_record   => $add_record );
3500   }
3501 }
3502
3503 end add_option
3504
3505 # }}} add_option
3506
3507 # {{{ remove_option
3508
3509 start remove_option
3510
3511 unless( $#problem_numbers >= 0 ){
3512   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
3513 }
3514
3515 my @problems = @{$self -> {'problems'}};
3516 foreach my $i ( @problem_numbers ) {
3517   if ( defined $problems[ $i-1 ] ) {
3518     $problems[$i-1] -> remove_option( record_name => $record_name,
3519                                       option_name => $option_name );
3520   }
3521 }
3522
3523 end remove_option
3524
3525 # }}} remove_option
3526
3527 # {{{ _option_val_pos
3528
3529 start _option_val_pos
3530       {
3531         unless( $#problem_numbers >= 0 ){
3532           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
3533         }
3534         my @problems = @{$self -> {'problems'}};
3535         if ( $#new_values >= 0 ) {
3536           'debug' -> die( message => "Trying to set option $name in record $record_name but the ".
3537                           "number of new value sets (".
3538                           ($#new_values+1).
3539                           "), do not match the number of problems specified (".
3540                           ($#problem_numbers+1).")" )
3541               unless(($#new_values == $#problem_numbers) );
3542           if ( $#instance_numbers > 0 ) {
3543               'debug' -> die( message => "The number of instance number sets (".
3544                               ($#instance_numbers+1).
3545                               "),do not match the number of problems specified (".
3546                               ($#problem_numbers+1).")" )
3547                 unless(($#instance_numbers == $#problem_numbers) );
3548           }
3549         }
3550
3551         foreach my $i ( @problem_numbers ) {
3552           if ( defined $problems[ $i-1 ] ) {
3553             my $rn_ref = $#instance_numbers >= 0 ? \@{$instance_numbers[ $i-1 ]} : [];
3554             if ( scalar @new_values > 0) {
3555               # {{{ Update values
3556
3557               if( not defined $new_values[ $i-1 ] ) {
3558                 debug -> die( message => " The specified new_values was undefined for problem $i" );
3559               }
3560
3561               if( not ref( $new_values[ $i-1 ] ) eq 'ARRAY' ) {
3562                 debug -> die( message => " The specified new_values for problem $i is not an array as it should be but a ".
3563                               ( defined ref( $new_values[ $i-1 ] ) ?
3564                                 ref( $new_values[ $i-1 ] ) : 'undef' ) );
3565               }
3566
3567               $problems[ $i-1 ] ->
3568                 _option_val_pos( record_name      => $record_name,
3569                                  instance_numbers => $rn_ref,
3570                                  new_values       => \@{$new_values[ $i-1 ]},
3571                                  name             => $name,
3572                                  exact_match      => $exact_match );
3573
3574               # }}} Update values
3575             } else {
3576               # {{{ Retrieve values
3577               my ( $val_ref, $pos_ref ) =
3578                 $problems[ $i-1 ] ->
3579                   _option_val_pos( record_name      => $record_name,
3580                                    instance_numbers => $rn_ref,
3581                                    name             => $name,
3582                                    exact_match      => $exact_match );
3583               push( @values, $val_ref );
3584               push( @positions, $pos_ref );
3585               # }}} Retrieve values
3586             }
3587           } else {
3588             'debug' -> die( message => "Problem number $i does not exist!" );
3589           }
3590         }
3591       }
3592 end _option_val_pos
3593
3594 # }}} _option_val_pos
3595
3596 # {{{ subroutine_files
3597
3598 start subroutine_files
3599 {
3600   my %fsubs;
3601   foreach my $subr( 'PRED','CRIT', 'CONTR', 'CCONTR', 'MIX', 'CONPAR', 'OTHER', 'PRIOR' ){
3602     my ( $model_fsubs, $junk ) = $self -> _option_val_pos( record_name => 'subroutine',
3603                                                            name => $subr );
3604     if( @{$model_fsubs} > 0 ){
3605       foreach my $prob_fsubs ( @{$model_fsubs} ){
3606         foreach my $fsub( @{$prob_fsubs} ){
3607           $fsubs{$fsub} = 1;
3608         }
3609       }
3610     }
3611   }
3612
3613   @fsubs = keys %fsubs;
3614   if( @fsubs > 0  ){
3615     for( my $i = 0; $i <= $#fsubs; $i ++ ){
3616       unless( $fsubs[$i] =~ /\.f$/ ){
3617         $fsubs[$i] .= '.f';
3618       }
3619     }
3620   }
3621 }
3622 end subroutine_files
3623
3624 # }}}