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 use Digest::MD5 'md5_hex';
   8 use Cwd;
   9 use File::Copy 'cp';
  10 use Config;
  11 use OSspecific;
  12 use Storable;
  13 use Data::Dumper;
  14 use POSIX qw(ceil floor);
  15 use model::shrinkage_module;
  16 end include statements
  17
  18 # }}} include statements
  19
  20 # {{{ description, synopsis and see_also
  21
  22 # No method, just documentation
  23 start description
  24
  25 =head1 Description
  26
  27 PsN::model is a Perl module for parsing and manipulating NONMEM model
  28 files.
  29
  30 The model class is built around the NONMEM model file. This is an
  31 ordinary ASCII text file that, except for the data, holds all
  32 information needed for fitting a non-linear mixed effect model using
  33 NONMEM. Typically, a model file contains specifications for a
  34 pharmacokinetic and/or a pharmacodynamic model, initial estimates of
  35 model parameters, boundaries for model parameters as well as details
  36 about the data location and format.
  37
  38 =cut
  39
  40 end description
  41
  42 start synopsis
  43
  44 =head1 Synopsis
  45
  46 C<< use model; >>
  47
  48 C<< my $model_object = model -> new ( filename => 'pheno.mod' ); >>
  49
  50 =begin html
  51
  52 <pre>
  53
  54 =end html
  55
  56 $model_object -> initial_values ( parameter_type    => 'theta',
  57                                   parameter_numbers => [[1,3]],
  58                                   new_values        => [[1.2,34]] );
  59
  60 =begin html
  61
  62 </pre>
  63
  64 =end html
  65
  66 =cut
  67
  68 end synopsis
  69
  70 start see_also
  71
  72 =head1 See also
  73
  74 =begin html
  75
  76 <a HREF="data.html">data</a>, <a HREF="output.html">output</a>
  77
  78 =end html
  79
  80 =begin man
  81
  82 data, output
  83
  84 =end man
  85
  86 =cut
  87
  88 end see_also
  89
  90 =head1 Methods
  91
  92 =cut
  93
  94 # }}}
  95
  96 # {{{ new
  97
  98 =head2 new
  99
 100 Usage:
 101
 102 =for html <pre>
 103
 104     $model = model -> new( filename => 'run1.mod' )
 105
 106 =for html </pre>
 107
 108 This is the simplest and most common way to create a model
 109 object and it requires a file on disk.
 110
 111 =for html <pre>
 112
 113     $model = model -> new( filename => 'run1.mod',
 114                            target   => 'mem' )
 115
 116 =for html </pre>
 117
 118 If the target parameter is set to anything other than I<mem>
 119 the output object (with file name given by the model
 120 attribute I<outputfile>) and the data objects (identified by
 121 the data file names in the $DATA NONMEM model file section)
 122 will be initialized but will contain no information from
 123 their files. If information from them are requiered later
 124 on, they are read and parsed and the appropriate attributes
 125 of the data and output objects are set.
 126
 127 =cut
 128
 129 start new
 130     {
 131
 132         if ( defined $parm{'problems'} ) {
 133             $this -> {'problems'} = $parm{'problems'};
 134         } else {
 135             ($this -> {'directory'}, $this -> {'filename'}) =
 136                 OSspecific::absolute_path( $this -> {'directory'}, $this -> {'filename'} );
 137             $this -> _read_problems;
 138             $this -> {'synced'} = 1;
 139         }
 140
 141         if ( defined $parm{'active_problems'} ) {
 142             $this -> {'active_problems'} = $parm{'active_problems'};
 143         } elsif ( defined $this -> {'problems'} ) {
 144             my @active = ();
 145             for ( @{$this -> {'problems'}} ) {
 146                 push( @active, 1 );
 147             }
 148             $this -> {'active_problems'} = \@active;
 149         }
 150
 151         if ( defined $this -> {'extra_data_files'} ){
 152           for( my $i; $i < scalar @{$this -> {'extra_data_files'}}; $i++ ){
 153             my ( $dir, $file ) = OSspecific::absolute_path( $this -> {'directory'}, $this -> {'extra_data_files'} -> [$i]);
 154             $this -> {'extra_data_files'} -> [$i] = $dir . $file;
 155           }
 156         }
 157
 158         # TODO Remove this if it works
 159         #my $subroutine_files = $this -> subroutine_files;
 160         #if( defined $subroutine_files and scalar @{$subroutine_files} > 0 ){
 161         #  push( @{$this -> {'extra_files'}}, @{$subroutine_files} );
 162         #}
 163
 164         if ( defined $this -> {'extra_files'} ){
 165           for( my $i; $i < scalar @{$this -> {'extra_files'}}; $i++ ){
 166             my ( $dir, $file ) = OSspecific::absolute_path( $this -> {'directory'}, $this -> {'extra_files'} -> [$i]);
 167             $this -> {'extra_files'} -> [$i] = $dir . $file;
 168           }
 169         }
 170
 171         # Read datafiles, if any.
 172         unless( defined $this -> {'datas'} and not $this -> {'quick_reload'} ){
 173             my @idcolumns = @{$this -> idcolumns};
 174             my @datafiles = @{$this -> datafiles('absolute_path' => 1)};
 175 #           my @datafiles = @{$this -> datafiles('absolute_path' => 0)};
 176             for ( my $i = 0; $i <= $#datafiles; $i++ ) {
 177               my $datafile = $datafiles[$i];
 178               my $idcolumn = $idcolumns[$i];
 179               my ( $cont_column, $wrap_column ) = $this -> {'problems'} -> [$i] -> cont_wrap_columns;
 180               my $ignoresign = defined $this -> ignoresigns ? $this -> ignoresigns -> [$i] : undef;
 181               my @model_header = @{$this -> {'problems'} -> [$i] -> header};
 182               if ( defined $idcolumn ) {
 183                 push ( @{$this -> {'datas'}}, data ->
 184                        new( idcolumn             => $idcolumn,
 185                             filename             => $datafile,
 186                             cont_column          => $cont_column,
 187                             wrap_column          => $wrap_column,
 188                             #model_header         => \@model_header,
 189                             ignoresign           => $ignoresign,
 190                             directory            => $this -> {'directory'},
 191                             ignore_missing_files => $this -> {'ignore_missing_files'} ||
 192                             $this -> {'ignore_missing_data'},
 193                             target               => $this -> {'target'}) );
 194               } else {
 195                 'debug' -> die( message => "New model to be created from ".$this -> full_name().
 196                                 ". Data file is ".$datafile.
 197                                 ". No id column definition found in the model file." );
 198               }
 199             }
 200         }
 201
 202         # Read outputfile, if any.
 203         if( ! defined $this -> {'outputs'} ) {
 204           unless( defined $this -> {'outputfile'} ){
 205             if( $this -> filename() =~ /\.mod$/ ) {
 206               ($this -> {'outputfile'} = $this -> {'filename'}) =~ s/\.mod$/.lst/;
 207             } else {
 208               $this -> outputfile( $this -> filename().'.lst' );
 209             }
 210           }
 211           push ( @{$this -> {'outputs'}}, output ->
 212                  new( filename             => $this -> {'outputfile'},
 213                       directory            => $this -> {'directory'},
 214                       ignore_missing_files =>
 215                       $this -> {'ignore_missing_files'} || $this -> {'ignore_missing_output_files'},
 216                       target               => $this -> {'target'},
 217                       model_id             => $this -> {'model_id'} ) );
 218         }
 219
 220         # Adding mirror_plots module here, since it can add
 221         # $PROBLEMS. Also it needs to know wheter an lst file exists
 222         # or not.
 223
 224         if( $this -> {'mirror_plots'} > 0 ){
 225           my $mirror_plot_module = model::mirror_plot_module -> new( base_model => $this,
 226                                                                      nr_of_mirrors => $this -> {'mirror_plots'},
 227                                                                      cwres => $this -> {'cwres'},
 228                                                                      mirror_from_lst => $this -> {'mirror_from_lst'});
 229           push( @{$this -> {'mirror_plot_modules'}}, $mirror_plot_module );
 230         }
 231
 232         if( $this -> {'iofv'} > 0 ){
 233           my $iofv_module = model::iofv_module -> new( base_model => $this,
 234                                                        nm_version => $this -> {'nm_version'});
 235           push( @{$this -> {'iofv_modules'}}, $iofv_module );
 236         }
 237
 238       }
 239 end new
 240
 241 # }}} new
 242
 243 # {{{ register_in_database
 244
 245 start register_in_database
 246   {
 247     if ( $PsN::config -> {'_'} -> {'use_database'} ) {
 248       # Backslashes messes up the sql syntax
 249       my $file_str = $self->{'filename'};
 250       my $dir_str = $self->{'directory'};
 251       $file_str =~ s/\\/\//g;
 252       $dir_str =~ s/\\/\//g;
 253
 254       # md5sum
 255       my $md5sum = md5_hex(OSspecific::slurp_file($self-> full_name ));
 256
 257       my $dbh = DBI -> connect("DBI:mysql:host=".$PsN::config -> {'_'} -> {'database_server'}.
 258                                ";databse=".$PsN::config -> {'_'} -> {'project'},
 259                                $PsN::config -> {'_'} -> {'user'},
 260                                $PsN::config -> {'_'} -> {'password'},
 261                                {'RaiseError' => 1});
 262
 263       my $sth;
 264
 265       my $select_arr = [];
 266
 267       if ( not $force ) {
 268         my $sth = $dbh -> prepare( "SELECT model_id FROM ".$PsN::config -> {'_'} -> {'project'}.
 269                                    ".model ".
 270                                    "WHERE filename = '$file_str' AND ".
 271                                    "directory = '$dir_str' AND ".
 272                                    "md5sum = '".$md5sum."'" );
 273         $sth -> execute or 'debug' -> die( message => $sth->errstr ) ;
 274
 275         $select_arr = $sth -> fetchall_arrayref;
 276       }
 277
 278       if ( scalar @{$select_arr} > 0 ) {
 279         'debug' -> warn( level   => 1,
 280                        message => "Found an old entry in the database matching the ".
 281                        "current model file" );
 282         if ( scalar @{$select_arr} > 1 ) {
 283           'debug' -> warn( level   => 1,
 284                          message => "Found more than one matching entry in database".
 285                          ", using the first" );
 286         }
 287         $self -> {'model_id'} = $select_arr->[0][0];
 288       } else {
 289         my ( $date_str, $time_str );
 290         if( $Config{osname} eq 'MSWin32' ){
 291           $date_str = `date /T`;
 292           $time_str = ' '.`time /T`;
 293         } else {
 294           # Assuming UNIX
 295           $date_str = `date`;
 296         }
 297         chomp($date_str);
 298         chomp($time_str);
 299         my $date_time = $date_str.$time_str;
 300         $sth = $dbh -> prepare("INSERT INTO ".$PsN::config -> {'_'} -> {'project'}.
 301                                ".model (filename,date,directory,md5sum) ".
 302                                "VALUES ('$file_str', '$date_time', '$dir_str','".
 303                                $md5sum."' )");
 304         $sth -> execute;
 305         $self -> {'model_id'} = $sth->{'mysql_insertid'};
 306       }
 307       $sth -> finish if ( defined $sth );
 308       $dbh -> disconnect;
 309     }
 310     $model_id = $self -> {'model_id'} # return the model_id;
 311   }
 312 end register_in_database
 313
 314 # }}} register_in_database
 315
 316 # {{{ shrinkage_stats
 317
 318 start shrinkage_stats
 319
 320 if ( $#problem_numbers > 0 and ref $enabled eq 'ARRAY' ){
 321   if ( $#problem_numbers != ( scalar @{$enabled} - 1 ) ) {
 322     'debug' -> die( message => "The number of problem_numbers ".($#problem_numbers+1).
 323                     "and enabled/disabled shrinkage_stats ".scalar @{$enabled}.
 324                     " do not match" );
 325   }
 326 }
 327 unless( $#problem_numbers > 0 ){
 328   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 329 }
 330 my @en_arr;
 331 if( ref \$enabled eq 'SCALAR' ) {
 332   for ( @problem_numbers ) {
 333     push( @en_arr, $enabled );
 334   }
 335 } elsif ( not ref $enabled eq 'ARRAY' ) {
 336   debug -> die( message => 'enabled must be a scalar or a reference to an array, '.
 337                 'not a reference to a '.ref($enabled).'.' );
 338 }
 339
 340 my @problems = @{$self -> {'problems'}};
 341 my $j = 0;
 342 foreach my $i ( @problem_numbers ) {
 343   if ( defined $problems[ $i-1 ] ) {
 344     if ( defined $en_arr[ $j ] ) {
 345       if( $en_arr[ $j ] ) {
 346         $problems[ $i-1 ] -> shrinkage_module -> enable;
 347       } else {
 348         $problems[ $i-1 ] -> shrinkage_module -> disable;
 349       }
 350 #       my $eta_file = $self -> filename.'_'.$i.'.etas';
 351 #       my $eps_file = $self -> filename.'_'.$i.'.wres';
 352 #       $problems[ $i-1 ] -> {'eta_shrinkage_table'} = $eta_file;
 353 #       $problems[ $i-1 ] -> {'wres_shrinkage_table'} = $eps_file;
 354     } else {
 355       push( @indicators, $problems[ $i-1 ] -> shrinkage_module -> status );
 356     }
 357   } else {
 358     'debug' -> die( message => "Problem number $i does not exist!" );
 359   }
 360   $j++;
 361 }
 362
 363 end shrinkage_stats
 364
 365 # }}} shrinkage_stats
 366
 367 start shrinkage_modules
 368 {
 369   if( defined $parm ){
 370     if( ref $parm ne 'ARRAY'
 371         or
 372         not ( scalar @{$parm} == scalar @{$self -> {'problems'}} ) ){
 373       'debug' -> die( message => 'New number of shrinkage modules must be equal to number of problems' );
 374     }
 375
 376     foreach my $prob( @{$self -> {'problems'}} ){
 377       my $new_module = shift( @{$parm} );
 378       $new_module -> model( $self );
 379       $prob -> shrinkage_module( shift( @{$parm} ) );
 380
 381     }
 382
 383   } else {
 384     my @return_array;
 385     foreach my $prob( @{$self -> {'problems'}} ){
 386       push( @return_array, $prob -> shrinkage_module );
 387     }
 388     return \@return_array;
 389   }
 390 }
 391 end shrinkage_modules
 392
 393 # {{{ wres_shrinkage
 394
 395 =head2 wres_shrinkage
 396
 397 Usage:
 398
 399 =for html <pre>
 400
 401 my $wres_shrink = $model_object -> wres_shrinkage();
 402
 403 =for html </pre>
 404
 405 Description:
 406
 407 Calculates wres shrinkage, a table file with wres is necessary. The
 408 return value is reference of and array with one an array per problem
 409 in it.
 410
 411 =cut
 412
 413 start wres_shrinkage
 414
 415 my @problems = @{$self -> {'problems'}};
 416 foreach my $problem ( @problems ) {
 417   push( @wres_shrinkage, $problem -> wres_shrinkage );
 418 }
 419
 420 end wres_shrinkage
 421
 422 # }}} wres_shrinkage
 423
 424 # {{{ eta_shrinkage
 425
 426 =head2 eta_shrinkage
 427
 428 Usage:
 429
 430 =for html <pre>
 431
 432 my $eta_shrink = $model_object -> eta_shrinkage();
 433
 434 =for html </pre>
 435
 436 Description:
 437
 438 Calculates eta shrinkage, a table file with eta is necessary. The
 439 return value is reference of and array with one an array per problem
 440 in it.
 441
 442 =cut
 443
 444 start eta_shrinkage
 445
 446 my @problems = @{$self -> {'problems'}};
 447 foreach my $problem ( @problems ) {
 448   push( @eta_shrinkage, $problem -> eta_shrinkage );
 449 }
 450
 451 end eta_shrinkage
 452
 453 # }}} eta_shrinkage
 454
 455 # {{{ nonparametric_code
 456
 457 start nonparametric_code
 458
 459 if ( $#problem_numbers > 0 and $#enabled > 0 ){
 460   if ( $#problem_numbers != $#enabled ) {
 461     'debug' -> die( message => "The number of problem_numbers ".($#problem_numbers+1).
 462                     "and enabled/disabled nonparametric_code ".($#enabled+1).
 463                     "do not match" );
 464   }
 465 }
 466 unless( $#problem_numbers > 0 ){
 467   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 468 }
 469 my @problems = @{$self -> {'problems'}};
 470 my $j = 0;
 471 foreach my $i ( @problem_numbers ) {
 472   if ( defined $problems[ $i-1 ] ) {
 473     if ( defined $enabled[ $j ] ) {
 474       $problems[ $i-1 ] -> nonparametric_code( $enabled[ $j ] );
 475     } else {
 476       push( @indicators, $problems[ $i-1 ] -> nonparametric_code );
 477     }
 478   } else {
 479     'debug' -> die( message => "Problem number $i does not exist!" );
 480   }
 481   $j++;
 482 }
 483
 484 end nonparametric_code
 485
 486 # }}} nonparametric_code
 487
 488 # {{{ add_nonparametric_code
 489
 490 start add_nonparametric_code
 491
 492 $self -> set_records( type           => 'nonparametric',
 493                        record_strings => [ 'MARGINALS UNCONDITIONAL' ] );
 494 $self -> set_option( record_name => 'estimation',
 495                       option_name => 'POSTHOC' );
 496 my ( $msfo_ref, $junk ) = $self ->
 497     _get_option_val_pos( name            => 'MSFO',
 498                          record_name     => 'estimation' );
 499 my @nomegas = @{$self -> nomegas};
 500
 501 for( my $i = 0; $i <= $#nomegas; $i++ ) { # loop the problems
 502   my $marg_str = 'ID';
 503   for( my $j = 0; $j <= $nomegas[$i]; $j++ ) {
 504     $marg_str = $marg_str.' COM('.($j+1).')=MG'.($j+1);
 505   }
 506   $marg_str = $marg_str.' FILE='.$self->filename.'.marginals'.
 507       ' NOAPPEND ONEHEADER NOPRINT';
 508   $self -> add_records( problem_numbers => [($i+1)],
 509                          type            => 'table',
 510                          record_strings  => [ $marg_str ] );
 511   $self -> remove_option( record_name => 'abbreviated',
 512                            option_name => 'COMRES' );
 513   $self -> add_option( record_name  => 'abbreviated',
 514                        option_name  => 'COMRES',
 515                        option_value => ($nomegas[$i]+1),
 516                        add_record   => 1 );  #Add $ABB if not existing
 517
 518   $self -> add_marginals_code( problem_numbers => [($i+1)],
 519                                nomegas         => [ $nomegas[$i] ] );
 520 }
 521
 522 if( not defined $msfo_ref ) {
 523   for( my $i = 0; $i < $self -> nproblems; $i++ ) {
 524     $self -> add_option( record_name =>  'estimation',
 525                           option_name =>  'MSFO',
 526                           option_value => $self -> filename.'.msfo'.($i+1) );
 527   }
 528 } else {
 529   for( my $i = 0; $i < scalar @{$msfo_ref}; $i++ ) {
 530     if( not defined $msfo_ref->[$i] or not defined $msfo_ref->[$i][0] ) {
 531       $self -> add_option( record_name =>  'estimation',
 532                             option_name =>  'MSFO',
 533                             option_value => $self -> filename.'.msfo'.($i+1) );
 534     }
 535   }
 536 }
 537
 538 end add_nonparametric_code
 539
 540 # }}} add_nonparametric_code
 541
 542 # {{{ flush_data
 543
 544 =head2 flush_data
 545
 546 Usage:
 547
 548 =for html <pre>
 549
 550 $model_object -> flush_data();
 551
 552 =for html </pre>
 553
 554 Description:
 555
 556 flush data calls the same method on each data object (usually one)
 557 which causes it to write data to disk and remove its data from memory.
 558
 559 =cut
 560
 561 start flush_data
 562       {
 563         if ( defined $self -> {'datas'} ) {
 564           foreach my $data ( @{$self -> {'datas'}} ) {
 565             $data -> flush;
 566           }
 567         }
 568       }
 569 end flush_data
 570
 571 # }}} flush_data
 572
 573 # {{{ full_name
 574
 575 =head2 full_name
 576
 577 Usage:
 578
 579 C<< my $file_name = $model_object -> full_name(); >>
 580
 581 Description:
 582
 583 full_name will return the name of the modelfile and its directory in a
 584 string. For example: "/users/guest/project/model.mod".
 585
 586 =cut
 587
 588 start full_name
 589     {
 590         $full_name =  $self -> {'directory'} . $self -> {'filename'};
 591     }
 592 end full_name
 593
 594 # }}}
 595
 596 # {{{ sync_output
 597
 598 This function is unused and should probably be removed.
 599
 600 # start __sync_output
 601       {
 602         unless( defined $self -> {'outputfile'} ){
 603           'debug' -> die( message => "No output file is set, cannot synchronize output" );
 604         }
 605         @{$self -> {'outputs'}} = ();
 606         push ( @{$self -> {'outputs'}}, output ->
 607                  new( filename             => $self -> {'outputfile'},
 608                       ignore_missing_files => $self -> {'ignore_missing_files'},
 609                       target               => $self -> {'target'},
 610                       model_id             => $self -> {'model_id'} ) );
 611       }
 612 # end __sync_output
 613
 614 # }}} sync_output
 615
 616 # {{{ add_marginals_code
 617
 618 start add_marginals_code
 619
 620 # add_marginals_code takes two arguments.
 621 #
 622 # - problem_numbers is an array holding the numbers of the problems in
 623 # which code should be added.
 624 #
 625 # - nomegas which is an array holding the number of (diagonal-element)
 626 # omegas of each problem given by problem_numbers.
 627 #
 628 # For each omega in each problem, verbatim code is added to make the
 629 # marginals available for printing (e.g. to a table file). COM(1) will
 630 # hold the nonparametric density, COM(2) the marginal cumulative value
 631 # for the first eta, COM(2) the marginal cumulative density for the
 632 # second eta and so on.
 633
 634 unless( $#problem_numbers >= 0 ){
 635   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 636 }
 637
 638 my @problems = @{$self -> {'problems'}};
 639 my $j = 0;
 640 foreach my $i ( @problem_numbers ) {
 641   if ( defined $problems[ $i-1 ] ) {
 642     $problems[$i-1] -> add_marginals_code( nomegas => $nomegas[ $j ]  );
 643   } else {
 644     'debug' -> die( message => "Problem number $i does not exist.");
 645   }
 646   $j++;
 647 }
 648
 649 end add_marginals_code
 650
 651 # }}} add_marginals_code
 652
 653 # {{{ add_records
 654
 655 =head2 add_records
 656
 657 Usage:
 658
 659 =for html <pre>
 660
 661 $model_object -> add_records( type => 'THETA',
 662                               record_strings => ['(0.1,15,23)'] );
 663
 664 =for html </pre>
 665
 666 Arguments:
 667
 668 =over 3
 669
 670 =item type
 671
 672 string
 673
 674 =item record_strings
 675
 676 array of strings
 677
 678 =item problem_numbers
 679
 680 array of integers
 681
 682 =back
 683
 684 Description:
 685
 686 add_records is used to add NONMEM control file records to the model
 687 object. The "type" argument is mandatory and must be a valid NONMEM
 688 record name, such as "PRED" or "THETA". Otherwise an error will be
 689 output and the program terminated (this is object to change, ideally
 690 we would only report an error and let the caller deal with it). The
 691 "record_strings" argument is a mandatory array of valid NONMEM record
 692 code. Each array corresponds to a line of the record code. There
 693 "problem_numbers" argument is optional and is an array of problems
 694 numbered from 1 for which the record is added, by default the record
 695 is added to all problems.
 696
 697 Notice that the records are appended to those that allready exists,
 698 which makes sence for records that do not exist and for initial
 699 values. For records like "DATA" or "PRED" you probably want to use
 700 "set_records".
 701
 702 =cut
 703
 704 start add_records
 705       {
 706         unless( $#problem_numbers >= 0 ){
 707           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 708         }
 709
 710         my @problems = @{$self -> {'problems'}};
 711         foreach my $i ( @problem_numbers ) {
 712           if ( defined $problems[ $i-1 ] ) {
 713 #       if( defined $self -> {'problems'} ){
 714 #           if( defined @{$self -> {'problems'}}[$problem_number - 1] ){
 715 #               my $problem = @{$self -> {'problems'}}[$problem_number - 1];
 716 #               $problem -> add_records( 'type' => $type,
 717 #                                        'record_strings' => \@record_strings );
 718             $problems[$i-1] -> add_records( 'type' => $type,
 719                                             'record_strings' => \@record_strings );
 720           } else {
 721             'debug' -> die( message => "Problem number $i does not exist.");
 722           }
 723         }
 724 # else {
 725 #           'debug' -> die( message => "Model -> add_records: No Problems in model object.") ;
 726 #       }
 727       }
 728 end add_records
 729
 730 # }}} add_records
 731
 732 # {{{ set_records
 733
 734 =head2 set_records
 735
 736 Usage:
 737
 738 =for html <pre>
 739
 740 $model_object -> set_records( type => 'THETA',
 741                               record_strings => ['(0.1,15,23)'] );
 742
 743 =for html </pre>
 744
 745 Arguments:
 746
 747 =over 3
 748
 749 =item type
 750
 751 string
 752
 753 =item record_strings
 754
 755 array of strings
 756
 757 =item problem_numbers
 758
 759 array of integers
 760
 761 =back
 762
 763 Description:
 764
 765 set_records works just like add_records but will replace any existing
 766 records in the model object.
 767
 768 =cut
 769
 770 start set_records
 771       {
 772         unless( $#problem_numbers >= 0 ){
 773           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 774         }
 775
 776         my @problems = @{$self -> {'problems'}};
 777         foreach my $i ( @problem_numbers ) {
 778           if ( defined $problems[ $i-1 ] ) {
 779 #       if( defined $self -> {'problems'} ){
 780 #           if( defined @{$self -> {'problems'}}[$problem_number - 1] ){
 781 #               my $problem = @{$self -> {'problems'}}[$problem_number - 1];
 782 #               $problem -> set_records( 'type' => $type,
 783 #                                        'record_strings' => \@record_strings );
 784             $problems[$i-1] -> set_records( 'type' => $type,
 785                                             'record_strings' => \@record_strings );
 786           } else {
 787             'debug' -> die( message => "Problem number $i does not exist." );
 788           }
 789         }
 790 # else {
 791 #         'debug' -> die( "No Problems in model object.") ;
 792 #       }
 793       }
 794 end set_records
 795
 796 # }}} set_records
 797
 798 # {{{ remove_records
 799
 800 =head2 remove_records
 801
 802 Usage:
 803
 804 =for html <pre>
 805
 806 $model_object -> remove_records( type => 'THETA' )
 807
 808 =for html </pre>
 809
 810 Arguments:
 811
 812 =over 3
 813
 814 =item type
 815
 816 string
 817
 818 =item problem_numbers
 819
 820 array of integers
 821
 822 =back
 823
 824 Description:
 825
 826 remove_records removes the record given in the "type" argument which
 827 must be a valid NONMEM record name.
 828
 829 =cut
 830
 831 start remove_records
 832       {
 833         unless( $#problem_numbers >= 0 ){
 834           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
 835         }
 836
 837         my @problems = @{$self -> {'problems'}};
 838         foreach my $i ( @problem_numbers ) {
 839           if ( defined $problems[ $i-1 ] ) {
 840 #       if( defined $self -> {'problems'} ){
 841 #           if( defined @{$self -> {'problems'}}[$problem_number - 1] ){
 842 #               my $problem = @{$self -> {'problems'}}[$problem_number - 1];
 843 #               $problem -> remove_records( 'type' => $type );
 844             $problems[$i-1] -> remove_records( 'type' => $type );
 845           } else {
 846             'debug' -> die( message => "Problem number $i, does not exist" );
 847           }
 848         }
 849 # else {
 850 #         'debug' -> die( message => "No Problems in model object." );
 851 #       }
 852       }
 853 end remove_records
 854
 855 # }}} remove_records
 856
 857 # {{{ copy
 858
 859 =head2 copy
 860
 861 Usage:
 862
 863 =for html <pre>
 864
 865 $model_object -> copy( filename => 'copy.mod',
 866                        copy_data => 1,
 867                        copy_output => 0 )
 868
 869 =for html </pre>
 870
 871 Arguments:
 872
 873 =over 3
 874
 875 =item filename
 876
 877 string
 878
 879 =item copy_data
 880
 881 boolean
 882
 883 =item copy_output
 884
 885 boolean
 886
 887 =item directory
 888
 889 string
 890
 891 =item data_file_names
 892
 893 array of strings
 894
 895 =item target
 896
 897 string with value 'disk' or 'mem'
 898
 899 =item extra_data_file_names
 900
 901 array of strings
 902
 903 =item update_shrinkage_tables
 904
 905 boolean
 906
 907 =back
 908
 909 Description:
 910
 911 copy produces a new modelfile object and a new file on disk whose name
 912 is given by the "filename" argument. To create copies of data file the
 913 copy_data options may be set to 1.  The values of "data_file_names",
 914 unless given, will be the model file name but with '.mod' exchanged
 915 for '_$i.dta', where $i is the problem number.  If data is not copied,
 916 a new data object will be intialized from the same data file as the
 917 previous model and "data_file_names" WILL BE IGNORED. This has the
 918 side effect that the data file can be modified from both the original
 919 model and the copy. The same holds for "extra_data_files". It is
 920 possible to set "copy_output" to 1 as well, which then copies the
 921 output object instead of reading the output file from disk, which is
 922 slower. Since output objects are meant to be read-only, no
 923 output_filename can be specified and the output object copy will
 924 reside in memory only.
 925
 926 The "target" option has no effect.
 927
 928 =cut
 929
 930 start copy
 931       {
 932         # PP_TODO fix a nice copying of modelfile data
 933         # preferably in memory copy. Perhaps flush data ?
 934
 935         # Check sanity of the length of data file names argument
 936         if ( scalar @data_file_names > 0 ) {
 937           'debug' -> die( message => "model -> copy: The number of specified new data file " .
 938                           "names ". scalar @data_file_names. "must\n match the number".
 939                           " of data objects connected to the model object".
 940                           scalar @{$self -> {'datas'}} )
 941               unless ( scalar @data_file_names == scalar @{$self -> {'datas'}} );
 942         } else {
 943           my $d_filename;
 944           ($d_filename = $filename) =~ s/\.mod$//;
 945           for ( my $i = 1; $i <= scalar @{$self -> {'datas'}}; $i++ ) {
 946             # Data filename is created in this directory (no directory needed).
 947             push( @data_file_names, $d_filename."_data_".$i."_copy.dta" );
 948           }
 949         }
 950
 951         # Check sanity of the length of extra_data file names argument
 952         if ( scalar @extra_data_file_names > 0 ) {
 953           'debug' -> die( message => "The number of specified new extra_data file ".
 954                           "names ". scalar @extra_data_file_names, "must\n match the number".
 955                           " of problems (one extra_data file per prolem)".
 956                           scalar @{$self -> {'extra_data_files'}} )
 957               unless( scalar @extra_data_file_names == scalar @{$self -> {'extra_data_files'}} );
 958         } else {
 959           if ( defined $self -> {'extra_data_files'} ) {
 960             my $d_filename;
 961             ($d_filename = $filename) =~ s/\.mod$//;
 962             for ( my $i = 1; $i <= scalar @{$self -> {'extra_data_files'}}; $i++ ) {
 963               # Extra_Data filename is created in this directory (no directory needed).
 964               push( @extra_data_file_names, $d_filename."_extra_data_".$i."_copy.dta" );
 965             }
 966           }
 967         }
 968
 969         ($directory, $filename) = OSspecific::absolute_path( $directory, $filename );
 970
 971         # New copy:
 972
 973         # save references to own data and output objects
 974         my $datas   = $self -> {'datas'};
 975 #       $Data::Dumper::Maxdepth = 2;
 976 #       die "MC1: ", Dumper $datas -> [0] -> {'individuals'};
 977         my $outputs = $self -> {'outputs'};
 978         my %extra_datas;
 979         my @problems = @{$self -> {'problems'}};
 980         for ( my $i = 0; $i <= $#problems; $i++ ) {
 981           if ( defined $problems[$i] -> {'extra_data'} ) {
 982             $extra_datas{$i} = $problems[$i] -> {'extra_data'};
 983           }
 984         }
 985
 986         my ( @new_datas, @new_extra_datas, @new_outputs );
 987
 988         $self -> synchronize if not $self -> {'synced'};
 989
 990         # remove ref to data and output object to speed up the
 991         # cloning
 992         $self -> {'datas'}   = undef;
 993         $self -> {'outputs'} = undef;
 994         for ( my $i = 0; $i <= $#problems; $i++ ) {
 995           $problems[$i] -> {'extra_data'} = undef;
 996         }
 997
 998         # Copy the data objects if so is requested
 999         if ( defined $datas ) {
1000           my $i = 0;
1001           foreach my $data ( @{$datas} ) {
1002             if ( $copy_data == 1 ) {
1003               push( @new_datas, $data ->
1004                     copy( filename => $data_file_names[$i]) );
1005             } else {
1006               # This line assumes one data per problem! May be a source of error.
1007               my ( $cont_column, $wrap_column ) = $self -> problems -> [$i] -> cont_wrap_columns;
1008               my $ignoresign = defined $self -> ignoresigns ? $self -> ignoresigns -> [$i] : undef;
1009               my @model_header = @{$self -> problems -> [$i] -> header};
1010               push @new_datas, data ->
1011                 new( filename             => $data -> filename,
1012                      directory            => $data -> directory,
1013                      cont_column          => $cont_column,
1014                      wrap_column          => $wrap_column,
1015                      #model_header        => \@model_header,
1016                      target               => 'disk',
1017                      ignoresign           => $ignoresign,
1018                      idcolumn             => $data -> idcolumn );
1019             }
1020             $i++;
1021           }
1022         }
1023
1024         # Copy the extra_data objects if so is requested
1025         for ( my $i = 0; $i <= $#problems; $i++ ) {
1026           my $extra_data = $extra_datas{$i};
1027           if ( defined $extra_data ) {
1028             if ( $copy_data == 1 ) {
1029               push( @new_extra_datas, $extra_data ->
1030                     copy( filename => $extra_data_file_names[$i]) );
1031             } else {
1032               push( @new_extra_datas, extra_data ->
1033                     new( filename             => $extra_data -> filename,
1034                          directory            => $extra_data -> directory,
1035                          target               => 'disk',
1036                          idcolumn             => $extra_data -> idcolumn ) );
1037             }
1038           }
1039         }
1040
1041
1042         # Clone self into new model object and set synced to 0 for
1043         # the copy
1044         $new_model = Storable::dclone( $self );
1045         $new_model -> {'synced'} = 0;
1046
1047 #       $Data::Dumper::Maxdepth = 3;
1048 #       die Dumper $new_datas[0] -> {'individuals'};
1049
1050         # Restore the data and output objects for self
1051         $self -> {'datas'} = $datas;
1052         $self -> {'outputs'} = $outputs;
1053         for ( my $i = 0; $i <= $#problems; $i++ ) {
1054           if( defined $extra_datas{$i} ){
1055             $problems[$i] -> {'extra_data'} = $extra_datas{$i};
1056           }
1057         }
1058
1059         # Set the new file name for the copy
1060         $new_model -> directory( $directory );
1061         $new_model -> filename( $filename );
1062
1063         # {{{ update the shrinkage modules
1064
1065         my @problems = @{$new_model -> problems};
1066         for( my $i = 1; $i <= scalar @problems; $i++ ) {
1067           $problems[ $i-1 ] -> shrinkage_module -> model( $new_model );
1068         }
1069
1070         # }}} update the shrinkage modules
1071
1072         # Copy the output object if so is requested (only one output
1073         # object defined per model object)
1074         if ( defined $outputs ) {
1075           foreach my $output ( @{$outputs} ) {
1076             if ( $copy_output == 1 ) {
1077               push( @new_outputs, $output -> copy );
1078             } else {
1079               my $new_out = $filename;
1080               if( $new_out =~ /\.mod$/ ) {
1081                 $new_out =~ s/\.mod$/\.lst/;
1082               } else {
1083                 $new_out = $new_out.'.lst';
1084               }
1085               push( @new_outputs, output ->
1086                     new ( filename => $new_out,
1087                           directory => $directory,
1088                           target   => 'disk',
1089                           ignore_missing_files => 1,
1090                           model_id => $new_model -> {'model_id'} ) );
1091             }
1092           }
1093         }
1094
1095         # Add the copied data and output objects to the model copy
1096         $new_model -> datas( \@new_datas );
1097
1098         if ( $#new_extra_datas >= 0 ) {
1099           my @new_problems = @{$new_model -> problems};
1100           for ( my $i = 0; $i <= $#new_problems; $i++ ) {
1101             $new_problems[$i] -> {'extra_data'} = $new_extra_datas[$i];
1102             if ( $copy_data == 1 ){
1103               $new_problems[$i] -> {'extra_data_file_name'} = $extra_data_file_names[$i];
1104             }
1105           }
1106         }
1107
1108         $new_model -> {'outputs'} = \@new_outputs;
1109
1110         $new_model -> _write;
1111
1112         $new_model -> synchronize if $target eq 'disk';
1113       }
1114 end copy
1115
1116 # }}} copy
1117
1118 # {{{ covariance
1119
1120 =head2 covariance
1121
1122 Usage:
1123
1124 =for html <pre>
1125
1126 my $indicators = $model_object -> covariance( enabled => [1] );
1127
1128 =for html </pre>
1129
1130 Arguments:
1131
1132 =over 3
1133
1134 =item enabled
1135
1136 array of booleans
1137
1138 =item problem_numbers
1139
1140 array of integers
1141
1142 =back
1143
1144 Description:
1145
1146 covariance will let you turn the covariance step on and off per
1147 problem. The "enabled" argument is an array which must have a length
1148 equal to the number of problems. Each element set to 0 will disable
1149 the covariance step for the corresponding problem. And conversely each
1150 element set to nonzero will enable the covariance step.
1151
1152 covariance will return an array with an element for each problem, the
1153 element will indicate whether the covariance step is turned on or not.
1154
1155 =cut
1156
1157 start covariance
1158       {
1159         if ( $#problem_numbers > 0 ){
1160           if ( $#problem_numbers != $#enabled ) {
1161             'debug' -> die( message => "The number of problem_numbers ".($#problem_numbers+1).
1162                           "and enabled/disabled covariance records ".($#enabled+1).
1163                           "do not match" );
1164           }
1165         }
1166         unless( $#problem_numbers > 0 ){
1167           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
1168         }
1169         my @problems = @{$self -> {'problems'}};
1170         my $j = 0;
1171         foreach my $i ( @problem_numbers ) {
1172           if ( defined $problems[ $i-1 ] ) {
1173             if ( defined $enabled[ $j ] ) {
1174               $problems[ $i-1 ] -> covariance( enabled => $enabled[ $j ] );
1175             } else {
1176               push( @indicators, $problems[ $i-1 ] -> covariance );
1177             }
1178           } else {
1179             'debug' -> die( message => "Problem number $i does not exist!" );
1180           }
1181           $j++;
1182         }
1183       }
1184 end covariance
1185
1186 # }}} covariance
1187
1188 # {{{ datas
1189
1190 =head2 datas
1191
1192 Usage:
1193
1194 =for html <pre>
1195
1196 $model_object -> datas( [$data_obj] );
1197
1198 my $data_objects = $model_object -> data;
1199
1200 =for html </pre>
1201
1202 Arguments:
1203
1204 The argument is an unnamed array of data objects.
1205
1206 Description:
1207
1208 If data is used without argument the data objects connected to the
1209 model object is returned. If an argument is given it must be an array
1210 of length equal to the number of problems with data objects. Those
1211 objects will replace any existing data objects and their filenames
1212 will be put in the model files records.
1213
1214 =cut
1215
1216 start datas
1217       {
1218         my $nprobs = scalar @{$self -> {'problems'}};
1219         if ( defined $parm ) {
1220           if ( ref($parm) eq 'ARRAY' ) {
1221             my @new_datas = @{$parm};
1222             # Check that new_headers and problems match
1223             'debug' -> die( message => "The number of problems $nprobs and".
1224                             " new data ". ($#new_datas+1) ." don't match in ".
1225                             $self -> full_name ) unless ( $#new_datas + 1 == $nprobs );
1226             if ( defined $self -> {'problems'} ) {
1227               for( my $i = 0; $i < $nprobs; $i++ ) {
1228                 $self -> _option_name( position   => 0,
1229                                        record     => 'data',
1230                                        problem_number => $i+1,
1231                                        new_name   => $new_datas[$i] -> filename);
1232               }
1233             } else {
1234               'debug' -> die( message => "No problems defined in ".
1235                               $self -> full_name );
1236             }
1237           } else {
1238             'debug' -> die( message => "Supplied new value is not an array" );
1239           }
1240         }
1241       }
1242 end datas
1243
1244 # }}}
1245
1246 # {{{ datafile
1247
1248 # TODO 2006-03-22
1249 # I have removed this because it was only used in the bootstrap. I
1250 # fixed the bootstrap to use datafiles instead. Also the bootstrap
1251 # methods who used this was very old and should probably be removed as
1252 # well.
1253
1254 # start datafile
1255       {
1256         # datafile either retrieves or sets a new name for the datafile in the first problem of the
1257         # model. This method is only here for compatibility reasons. Don't use it. Use L</datafiles> instead.
1258
1259         if( defined $new_name ){
1260           $self -> _option_name( position => 0,
1261                                  record   => 'data',
1262                                  problem_number  => $problem_number,
1263                                  new_name => $new_name);
1264           my ( $cont_column, $wrap_column ) = $self -> problems -> [$problem_number-1] ->
1265             cont_wrap_columns;
1266           my $ignoresign = defined $self -> ignoresigns ?
1267             $self -> ignoresigns -> [$problem_number-1] : undef;
1268           my @model_header = @{$self -> problems -> [$problem_number-1] -> header};
1269           $self -> {'datas'} -> [$problem_number-1] = data ->
1270             new( idcolumn             => $self -> idcolumn( problem_number => $problem_number ),
1271                  ignoresign           => $ignoresign,
1272                  filename             => $new_name,
1273                  cont_column          => $cont_column,
1274                  wrap_column          => $wrap_column,
1275                  #model_header         => \@model_header,
1276                  ignore_missing_files => $self -> {'ignore_missing_files'},
1277                  target               => $self -> {'target'} );
1278         } else {
1279             $name = $self -> _option_name( position => 0, record => 'data', problem_number => $problem_number );
1280         }
1281       }
1282 # end datafile
1283
1284 # }}} datafile
1285
1286 # {{{ datafiles
1287
1288 =head2 datafiles
1289
1290 Usage:
1291
1292 =for html <pre>
1293
1294 $model_object -> datafiles( new_names => ['datafile.dta'] );
1295
1296 =for html </pre>
1297
1298 Arguments:
1299
1300 =over 2
1301
1302 =item new_names
1303
1304 array of strings
1305
1306 =item problem_numbers
1307
1308 array of integer
1309
1310 =item absolute_path
1311
1312 boolean
1313
1314 =back
1315
1316 Description:
1317
1318 datafiles changes the names of the data files in a model file. The
1319 "new_names" argument is an array of strings, where each string gives
1320 the file name of a problem data file. The length of "new_names" must
1321 be equal to the "problem_numbers" argument. "problem_numbers" is by
1322 default containing all of the models problems numbers. In the example
1323 above we only have one problem in the model file and therefore only
1324 need to give on new file name.
1325
1326 Unless new_names is given datafiles returns the names of the data
1327 files used by the model file. If the optional "absolute_path" argument
1328 is given, the returned file names will have the path to file as well.
1329
1330 =cut
1331
1332 start datafiles
1333       {
1334         # The datafiles method retrieves or sets the names of the
1335         # datafiles specified in the $DATA record of each problem. The
1336         # problem_numbers argument can be used to control which
1337         # problem that is affected. If absolute_path is set to 1, the
1338         # returned file names are given with absolute paths.
1339
1340         unless( $#problem_numbers > 0 ){
1341           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
1342         }
1343         if ( scalar @new_names > 0 ) {
1344           my $i = 0;
1345           my @idcolumns = @{$self ->
1346                               idcolumns( problem_numbers => \@problem_numbers )};
1347           foreach my $new_name ( @new_names ) {
1348             if ( $absolute_path ) {
1349               my $tmp;
1350               ($tmp, $new_name) = OSspecific::absolute_path('', $new_name );
1351               $new_name = $tmp . $new_name;
1352             }
1353
1354             $self -> _option_name( position       => 0,
1355                                    record         => 'data',
1356                                    problem_number => $problem_numbers[$i],
1357                                    new_name       => $new_name);
1358             my ( $cont_column, $wrap_column ) = $self -> problems ->
1359               [$problem_numbers[$i]-1] -> cont_wrap_columns;
1360             my $ignoresign = defined $self -> ignoresigns ? $self -> ignoresigns -> [$i] : undef;
1361             my @model_header = @{$self -> problems -> [$i] -> header};
1362             $self -> {'datas'} -> [$problem_numbers[$i]-1] = data ->
1363               new( idcolumn             => $idcolumns[$i],
1364                    ignoresign           => $ignoresign,
1365                    filename             => $new_name,
1366                    cont_column          => $cont_column,
1367                    wrap_column          => $wrap_column,
1368                    #model_header         => \@model_header,
1369                    ignore_missing_files => $self -> {'ignore_missing_files'},
1370                    target               => $self -> {'target'} );
1371             $i++;
1372           }
1373         } else {
1374           foreach my $prob_num ( @problem_numbers ) {
1375             if ( $absolute_path ) {
1376               my ($d_dir, $d_name);
1377               ($d_dir, $d_name) =
1378                   OSspecific::absolute_path($self -> {'directory'}, $self ->_option_name( position       => 0,
1379                                                                                           record         => 'data',
1380                                                                                           problem_number => $prob_num ) );
1381               push( @names, $d_dir . $d_name );
1382             } else {
1383               my $name = $self -> _option_name( position       => 0,
1384                                                 record         => 'data',
1385                                                 problem_number => $prob_num );
1386               $name =~ s/.*[\/\\]//;
1387               push( @names, $name );
1388             }
1389           }
1390         }
1391       }
1392 end datafiles
1393
1394 # }}} datafiles
1395
1396 # {{{ des
1397
1398 # TODO 2006-03-22
1399 # This method is renamed __des in dia but not here. If nothing broke
1400 # until now I think we can safely remove it.
1401
1402 start des
1403       {
1404         # Returns the des part specified subproblem.
1405         # TODO: Even though new_des can be specified, they wont be set
1406         # in to the object.
1407
1408         my @prob = @{$self    -> problems};
1409         my @des  = @{$prob[$problem_number - 1] -> get_record('des') -> code}
1410         if ( defined $prob[$problem_number - 1] -> get_record('des') );
1411       }
1412 end des
1413
1414 # }}} des
1415
1416 # {{{ eigen
1417 start eigen
1418       {
1419         $self -> {'problems'} -> [0] -> eigen;
1420       }
1421 end eigen
1422 # }}} eigen
1423
1424 # {{{ error
1425
1426 # TODO 2006-03-22
1427 # This method is renamed __error in dia but not here. If nothing broke
1428 # until now I think we can safely remove it.
1429
1430 start error
1431       {
1432         # Usage:
1433         #
1434         # @error = $modelObject -> error;
1435         #
1436         # Returns the error part specified subproblem.
1437         # TODO: Even though new_error can be specified, they wont be set
1438         # in to the object.
1439         my @prob = @{$self    -> problems};
1440         my @error = @{$prob[0] -> get_record('error') -> code}
1441           if ( defined $prob[0] -> get_record('error') );
1442       }
1443 end error
1444
1445 # }}} error
1446
1447 # {{{ extra_data_files
1448
1449 =head2 extra_data_files
1450
1451 Usage:
1452
1453 =for html <pre>
1454
1455 $model_object -> extra_data_files( ['extra_data.dta'] );
1456
1457 my $extra_file_name = $model_object -> extra_data_files;
1458
1459 =for html </pre>
1460
1461 Arguments:
1462
1463 The argument is an unnamed array of strings
1464
1465 Description:
1466
1467 If extra_data_files is used without argument the names of any extra
1468 data files connected to the model object is returned. If an argument
1469 is given it must be an array of length equal to the number of problems
1470 in the model. Then the names of the extra data files will be changed
1471 to those in the array.
1472
1473 =cut
1474
1475 start extra_data_files
1476       {
1477         my @file_names;
1478         # Sets or retrieves extra_data_file_name on problem level
1479         my $nprobs = scalar @{$self -> {'problems'}};
1480         if ( defined $parm ) {
1481           if ( ref($parm) eq 'ARRAY' ) {
1482             my @new_file_names = @{$parm};
1483             # Check that new_file_names and problems match
1484             'debug' -> die( message => "model -> extra_data_files: The number of problems $nprobs and" .
1485                             " new_file_names " . $#new_file_names+1 . " don't match in ".
1486                             $self -> full_name ) unless ( $#new_file_names + 1 == $nprobs );
1487             if ( defined $self -> {'problems'} ) {
1488               for( my $i = 0; $i < $nprobs; $i++ ) {
1489                 $self -> {'problems'} -> [$i] -> extra_data_file_name( $new_file_names[$i] );
1490               }
1491             } else {
1492               'debug' -> die( message => "No problems defined in " .
1493                               $self -> full_name );
1494             }
1495           } else {
1496             'debug' -> die(message => "Supplied new value is not an array.");
1497           }
1498         } else {
1499           if ( defined $self -> {'problems'} ) {
1500             for( my $i = 0; $i < $nprobs; $i++ ) {
1501               if( defined $self -> {'problems'} -> [$i] -> extra_data_file_name ) {
1502                 push ( @file_names ,$self -> {'problems'} -> [$i] -> extra_data_file_name );
1503               }
1504             }
1505           }
1506         }
1507         return \@file_names;
1508      }
1509 end extra_data_files
1510
1511 # }}}
1512
1513 # {{{ extra_data_headers
1514
1515 =head2 extra_data_headers
1516
1517 Usage:
1518
1519 =for html <pre>
1520
1521 $model_object -> extra_data_headers( [$data_obj] );
1522
1523 my $data_objects = $model_object -> extra_data_headers;
1524
1525 =for html </pre>
1526
1527 Arguments:
1528
1529 The argument is an unnamed array of arrays of strings.
1530
1531 Description:
1532
1533 If extra_data_files is used without argument the headers of any extra
1534 data files connected to the model object is returned. If an argument
1535 is given it must be an array of length equal to the number of problems
1536 in the model. Then the headers of the extra data files will be changed
1537 to those in the array.
1538
1539 =cut
1540
1541 start extra_data_headers
1542       {
1543         my @headers;
1544         # Sets or retrieves extra_data_header on problem level
1545         my $nprobs = scalar @{$self -> {'problems'}};
1546         if ( defined $parm ) {
1547           if ( ref($parm) eq 'ARRAY' ) {
1548             my @new_headers = @{$parm};
1549             # Check that new_headers and problems match
1550             'debug' -> die( message => "The number of problems $nprobs and".
1551                             " new_headers " . $#new_headers+1 . " don't match in ".
1552                             $self -> full_name) unless ( $#new_headers + 1 == $nprobs );
1553             if ( defined $self -> {'problems'} ) {
1554               for( my $i = 0; $i < $nprobs; $i++ ) {
1555                 $self -> {'problems'} -> [$i] -> extra_data_header( $new_headers[$i] );
1556               }
1557             } else {
1558               'debug' -> die( message => "No problems defined in " .  $self -> full_name );
1559             }
1560           } else {
1561             'debug' -> die( message => "Supplied new value is not an array" );
1562           }
1563         } else {
1564           if ( defined $self -> {'problems'} ) {
1565             for( my $i = 0; $i < $nprobs; $i++ ) {
1566               push ( @headers, $self -> {'problems'} -> [$i] -> extra_data_header );
1567             }
1568           }
1569         }
1570         return \@headers;
1571      }
1572 end extra_data_headers
1573
1574 # }}} extra_data_headers
1575
1576 # {{{ input_files
1577
1578 =head2 input_files
1579
1580 Usage:
1581
1582 =for html <pre>
1583
1584 my @file_names = $model_object -> input_files();
1585
1586 =for html </pre>
1587
1588 Arguments:
1589
1590 none
1591
1592 Description:
1593
1594 Returns an two dimensional array with filenames to files that are
1595 necessary for a NONMEM run, i.e. all input files.
1596
1597 The first level of the array is the list of files, the second level is
1598 allways of length two and contains the path and then the file.
1599
1600 Example return value:
1601
1602 [ ['/path/to', 'filename'],
1603   ['/another/path/to', 'another_file'] ]
1604
1605 =cut
1606
1607 start input_files
1608 {
1609
1610   # TODO: Skip the dataset for now, when I [PP] rewrite the
1611   # "model::copy" routine, I will revisit this.
1612
1613   if( 0 ){
1614     foreach my $data ( @{$self -> datas} ) {
1615       my $filename = $data -> filename;
1616
1617       #push( @new_data_names, $filename );
1618     }
1619   }
1620
1621   # msfi files
1622   if( scalar @{$self -> msfi_names()} > 0 ){
1623     foreach my $msfi_files( @{$self -> msfi_names()} ){
1624       foreach my $msfi_file( @{$msfi_files} ){
1625         my ( $dir, $filename ) = OSspecific::absolute_path($self -> directory,
1626                                                            $msfi_file );
1627         push( @file_names, [$dir, $filename] );
1628       }
1629     }
1630   } else {
1631
1632     # If we don't have $MSFI we can consider $EST MSFO as input.
1633
1634     foreach my $msfo_files( @{$self -> msfo_names()} ){
1635       foreach my $msfo_file( @{$msfo_files} ){
1636         my ( $dir, $filename ) = OSspecific::absolute_path($self -> directory,
1637                                                            $msfo_file );
1638         push( @file_names, [$dir, $filename] );
1639       }
1640     }
1641   }
1642
1643   # TODO: as with data files, revisit this when model::copy is
1644   # rewritten.
1645
1646   if( 0 ){
1647     my @problems = @{$self -> problems};
1648     for ( my $i = 1; $i <= $#problems + 1; $i++ ) {
1649       my $extra_data = $problems[$i-1] -> extra_data;
1650       if ( defined $extra_data ) {
1651         my $filename = $extra_data -> filename;
1652
1653         #push( @, $filename );
1654       }
1655     }
1656   }
1657
1658   # Copy extra fortran files specified in "$SUBROUTINE"
1659
1660   if( defined( $self -> subroutine_files ) ){
1661     foreach my $sub_file ( @{$self -> subroutine_files} ){
1662       my ( $dir, $filename ) = OSspecific::absolute_path( $self -> directory,
1663                                                           $sub_file );
1664       push( @file_names, [$dir, $filename] );
1665     }
1666   }
1667
1668   # Copy extra files the user specified.
1669
1670   if( defined $self -> extra_files ){
1671     foreach my $x_file (@{$self -> extra_files}){
1672       my ( $dir, $filename ) = OSspecific::absolute_path( $self -> directory,
1673                                                           $x_file );
1674       push( @file_names, [$dir, $filename] );
1675     }
1676   }
1677 }
1678 end input_files
1679
1680 # }}}
1681
1682 # {{{ output_files
1683
1684 =head2 output_files
1685
1686 Usage:
1687
1688 =for html <pre>
1689
1690 my @file_names = $model_object -> output_files();
1691
1692 =for html </pre>
1693
1694 Arguments:
1695
1696 none
1697
1698 Description:
1699
1700 Returns an array with filenames to files that are produced by a NONMEM
1701 run, i.e. all output files.
1702
1703 Example return value:
1704
1705 [ 'psn.lst',
1706   'patab' ]
1707
1708 =cut
1709
1710 start output_files
1711 {
1712
1713   push( @file_names, $self -> outputs -> [0] -> filename );
1714
1715   if( defined $self -> table_names ){
1716     foreach my $table_files( @{$self -> table_names} ){
1717       foreach my $table_file( @{$table_files} ){
1718         my ($dir, $filename) = OSspecific::absolute_path( undef,
1719                                                           $table_file );
1720         push( @file_names, $filename );
1721       }
1722     }
1723   }
1724
1725   if( defined $self -> msfo_names() ){
1726     foreach my $msfo_files( @{$self -> msfo_names()} ){
1727       foreach my $msfo_file( @{$msfo_files} ){
1728         my ( $dir, $filename ) = OSspecific::absolute_path( undef,
1729                                                             $msfo_file );
1730         push( @file_names, $filename );
1731       }
1732     }
1733   }
1734
1735   if( defined $self -> {'extra_output'} ){
1736     foreach my $extra_out ( @{$self -> {'extra_output'}} ){
1737       push( @file_names, $extra_out );
1738     }
1739   }
1740
1741
1742   my @problems = @{$self -> problems};
1743   for( my $i = 0; $i <= $#problems; $i++ ) {
1744     if( $problems[$i-1] -> shrinkage_module -> enabled ) {
1745       my ( $dir, $eta_filename ) =
1746           OSspecific::absolute_path( undef,
1747                                      $problems[$i] -> shrinkage_module -> eta_tablename );
1748
1749       push( @file_names, $eta_filename );
1750
1751       my ( $dir, $wres_filename ) =
1752           OSspecific::absolute_path( undef,
1753                                      $problems[$i] -> shrinkage_module -> wres_tablename );
1754
1755       push( @file_names, $wres_filename );
1756     }
1757   }
1758
1759 }
1760 end output_files
1761
1762 # }}}
1763
1764 # {{{ factors
1765
1766 =head2 factors
1767
1768 Usage:
1769
1770 =for html <pre>
1771
1772 my $factors = $model_object -> factors;
1773
1774 =for html </pre>
1775
1776 Arguments:
1777
1778 =over 2
1779
1780 =item colunm
1781
1782 number
1783
1784 =item column_head
1785
1786 string
1787
1788 =item problem_number
1789
1790 integer
1791
1792 =item return_occurences
1793
1794 boolean
1795
1796 =item unique_in_individual
1797
1798 boolean
1799
1800 =back
1801
1802 Description:
1803
1804 The following text comes from the documentation of
1805 data::factors. model::factors will call data::factors for the given
1806 problem number in the model object. Also it will take try to find
1807 "column_head" in the $INPUT record instead of the data file header.
1808
1809 Either column (number, starting at 1) or column_head must be
1810 specified. The default behaviour is to return a hash with the factors
1811 as keys referencing arrays with the order numbers (not the ID numbers)
1812 of the individuals that contain this factor.
1813
1814 If unique_in_individual is true (1), the returned hash will contain an
1815 element with key 'Non-unique values found' and value 1 if any
1816 individual contain more than one value in the specified column.
1817
1818 Return occurences will calculate the occurence of each factor
1819 value. Several occurences in one individual counts as one
1820 occurence. The elements of the returned hash will have the factors as
1821 keys and the number of occurences as values.
1822
1823 =cut
1824
1825 start factors
1826       {
1827         # Calls <I>factors</I> on the data object of a specified
1828         # problem. See <I>data -> factors</I> for details.
1829         my $column_number;
1830         my $extra_data_column;
1831         if ( defined $column_head ) {
1832           # Check normal data object first
1833           my ( $values_ref, $positions_ref ) = $self ->
1834             _get_option_val_pos ( problem_numbers => [$problem_number],
1835                                   name        => $column_head,
1836                                   record_name => 'input',
1837                                   global_position => 1 );
1838           $column_number = $positions_ref -> [0];
1839           # Next, check extra_data
1840           my $extra_data_headers = $self -> extra_data_headers;
1841           if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
1842             for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
1843               $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
1844             }
1845           }
1846           'debug' -> die( message => "Unknown column \"$column_head\"" )
1847               unless ( defined $column_number or defined $extra_data_column );
1848         } else {
1849           $column_number = $column;
1850         }
1851         if ( defined $column_number) {
1852           %factors = %{$self -> {'datas'} -> [$problem_number-1] ->
1853                          factors( column => $column_number,
1854                                   unique_in_individual => $unique_in_individual,
1855                                   return_occurences => $return_occurences )};
1856         } else {
1857           %factors = %{$self -> {'problems'} -> [$problem_number-1] -> extra_data
1858                          -> factors( column => $extra_data_column,
1859                                      unique_in_individual => $unique_in_individual,
1860                                      return_occurences => $return_occurences )};
1861         }
1862       }
1863 end factors
1864
1865 # }}}
1866
1867 # {{{ fractions
1868
1869 =head2 fractions
1870
1871 Usage:
1872
1873 =for html <pre>
1874
1875 my $fractions = $model_object -> fractions;
1876
1877 =for html </pre>
1878
1879 Arguments:
1880
1881 =over 2
1882
1883 =item colunm
1884
1885 number
1886
1887 =item column_head
1888
1889 string
1890
1891 =item problem_number
1892
1893 integer
1894
1895 =item return_occurences
1896
1897 boolean
1898
1899 =item ignore_missing
1900
1901 boolean
1902
1903 =back
1904
1905 Description:
1906
1907 fractions will return the fractions from data::fractions. It will find
1908 "column_head" in the $INPUT record instead of that data header as
1909 data::fractions does.
1910
1911 =cut
1912
1913 start fractions
1914       {
1915         # Calls <I>fractions</I> on the data object of a specified
1916         # problem. See <I>data -> fractions</I> for details.
1917         my $column_number;
1918         my $extra_data_column;
1919         if ( defined $column_head ) {
1920           # Check normal data object first
1921           my ( $values_ref, $positions_ref ) = $self ->
1922             _get_option_val_pos ( problem_numbers => [$problem_number],
1923                                   name        => $column_head,
1924                                   record_name => 'input',
1925                                   global_position => 1 );
1926           $column_number = $positions_ref -> [0];
1927           # Next, check extra_data
1928           my $extra_data_headers = $self -> extra_data_headers;
1929           if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
1930             for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
1931               $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
1932             }
1933           }
1934           'debug' -> die( "Unknown column \"$column_head\"" )
1935               unless ( defined $column_number or defined $extra_data_column );
1936         } else {
1937           $column_number = $column;
1938         }
1939         if ( defined $column_number) {
1940           %fractions = %{$self -> {'datas'} -> [$problem_number-1] ->
1941                            fractions( column => $column_number,
1942                                       unique_in_individual => $unique_in_individual,
1943                                       ignore_missing       => $ignore_missing )};
1944         } else {
1945           %fractions = %{$self -> {'problems'} -> [$problem_number-1] -> extra_data
1946                            -> fractions( column               => $extra_data_column,
1947                                          unique_in_individual => $unique_in_individual,
1948                                          ignore_missing       => $ignore_missing )};
1949         }
1950       }
1951 end fractions
1952
1953 # }}}
1954
1955 # {{{ fixed
1956
1957 =head2 fractions
1958
1959 Usage:
1960
1961 =for html <pre>
1962
1963 my $fractions = $model_object -> fractions;
1964
1965 =for html </pre>
1966
1967 Arguments:
1968
1969 =over 2
1970
1971 =item colunm
1972
1973 number
1974
1975 =item column_head
1976
1977 string
1978
1979 =item problem_number
1980
1981 integer
1982
1983 =item return_occurences
1984
1985 boolean
1986
1987 =item ignore_missing
1988
1989 boolean
1990
1991 =back
1992
1993 Description:
1994
1995 fractions will return the fractions from data::fractions. It will find
1996 "column_head" in the $INPUT record instead of that data header as
1997 data::fractions does.
1998
1999 =cut
2000
2001 start fixed
2002       {
2003           # Sets or gets the 'fixed' status of a (number of)
2004           # parameter(s). 1 correspond to a parameter being fixed and
2005           # 0 not fixed. The returned parameter is a reference to a
2006           # two-dimensional array, indexed by problems and parameter
2007           # numbers.
2008           # Valid parameter types are 'theta', 'omega' and 'sigma'.
2009
2010         @fixed = @{ $self -> _init_attr
2011                       ( parameter_type    => $parameter_type,
2012                         parameter_numbers => \@parameter_numbers,
2013                         problem_numbers           => \@problem_numbers,
2014                         new_values        => \@new_values,
2015                         attribute         => 'fix')};
2016       }
2017 end fixed
2018
2019 # }}} fixed
2020
2021 # {{{ have_missing_data
2022
2023 =head2 fractions
2024
2025 Usage:
2026
2027 =for html <pre>
2028
2029 my $fractions = $model_object -> fractions;
2030
2031 =for html </pre>
2032
2033 Arguments:
2034
2035 =over 2
2036
2037 =item colunm
2038
2039 number
2040
2041 =item column_head
2042
2043 string
2044
2045 =item problem_number
2046
2047 integer
2048
2049 =item return_occurences
2050
2051 boolean
2052
2053 =item ignore_missing
2054
2055 boolean
2056
2057 =back
2058
2059 Description:
2060
2061 fractions will return the fractions from data::fractions. It will find
2062 "column_head" in the $INPUT record instead of that data header as
2063 data::fractions does.
2064
2065 =cut
2066
2067 start have_missing_data
2068       {
2069         # Calls <I>have_missing_data</I> on the data object of a specified
2070         # problem. See <I>data -> have_missing_data</I> for details.
2071         my $column_number;
2072         my $extra_data_column;
2073         if ( defined $column_head ) {
2074           # Check normal data object first
2075           my ( $values_ref, $positions_ref ) = $self ->
2076             _get_option_val_pos ( problem_numbers => [$problem_number],
2077                                   name        => $column_head,
2078                                   record_name => 'input',
2079                                   global_position => 1  );
2080           $column_number = $positions_ref -> [0];
2081           # Next, check extra_data
2082           my $extra_data_headers = $self -> extra_data_headers;
2083           if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
2084             for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
2085               $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
2086             }
2087           }
2088           'debug' -> die( message => "Unknown column \"$column_head\"" )
2089               unless ( defined $column_number or defined $extra_data_column );
2090         } else {
2091           $column_number = $column;
2092         }
2093         if ( defined $column_number) {
2094           $return_value = $self -> {'datas'} -> [$problem_number-1] ->
2095             have_missing_data( column => $column_number );
2096         } else {
2097           $return_value = $self -> {'problems'} -> [$problem_number-1] ->
2098             extra_data -> have_missing_data( column => $extra_data_column );
2099         }
2100     }
2101 end have_missing_data
2102
2103 # }}}
2104
2105 # {{{ idcolumn
2106
2107 =head2 fractions
2108
2109 Usage:
2110
2111 =for html <pre>
2112
2113 my $fractions = $model_object -> fractions;
2114
2115 =for html </pre>
2116
2117 Arguments:
2118
2119 =over 2
2120
2121 =item colunm
2122
2123 number
2124
2125 =item column_head
2126
2127 string
2128
2129 =item problem_number
2130
2131 integer
2132
2133 =item return_occurences
2134
2135 boolean
2136
2137 =item ignore_missing
2138
2139 boolean
2140
2141 =back
2142
2143 Description:
2144
2145 fractions will return the fractions from data::fractions. It will find
2146 "column_head" in the $INPUT record instead of that data header as
2147 data::fractions does.
2148
2149 =cut
2150
2151 start idcolumn
2152       {
2153         # Usage:
2154         #
2155         #   @idcolumns = @{$modelObject -> idcolumns( problem_numbers => [2,3] );
2156         #
2157         # idcolumns returns the idcolumn index in the datafile for the
2158         # specified problem.
2159
2160         my $junk_ref;
2161         ( $junk_ref, $col ) = $self ->
2162           _get_option_val_pos( name => 'ID',
2163                                record_name => 'input',
2164                                problem_numbers => [$problem_number] );
2165
2166         if ( $problem_number ne 'all' ) {
2167           $col = @{$col}[0];
2168         }
2169       }
2170 end idcolumn
2171
2172 # }}} idcolumn
2173
2174 # {{{ idcolumns
2175
2176 =head2 fractions
2177
2178 Usage:
2179
2180 =for html <pre>
2181
2182 my $fractions = $model_object -> fractions;
2183
2184 =for html </pre>
2185
2186 Arguments:
2187
2188 =over 2
2189
2190 =item colunm
2191
2192 number
2193
2194 =item column_head
2195
2196 string
2197
2198 =item problem_number
2199
2200 integer
2201
2202 =item return_occurences
2203
2204 boolean
2205
2206 =item ignore_missing
2207
2208 boolean
2209
2210 =back
2211
2212 Description:
2213
2214 fractions will return the fractions from data::fractions. It will find
2215 "column_head" in the $INPUT record instead of that data header as
2216 data::fractions does.
2217
2218 =cut
2219
2220 start idcolumns
2221       {
2222         # Usage:
2223         #
2224         #   @column_numbers = @{$modelObject -> idcolumns( problem_numbers => [2] )};
2225         #
2226         # idcolumns returns the idcolumn indexes in the datafile for the
2227         # specified problems.
2228
2229         my ( $junk_ref, $col_ref ) = $self ->
2230           _get_option_val_pos( name            => 'ID',
2231                                record_name     => 'input',
2232                                problem_numbers => \@problem_numbers );
2233         # There should only be one instance of $INPUT and hence we collapse
2234         # the two-dim return from _get_option_pos_val to a one-dim array:
2235
2236         foreach my $prob ( @{$col_ref} ) {
2237           foreach my $inst ( @{$prob} ) {
2238             push( @column_numbers, $inst );
2239           }
2240         }
2241       }
2242 end idcolumns
2243
2244 # }}} idcolumns
2245
2246 # {{{ ignoresigns
2247
2248 =head2 ignoresigns
2249
2250 Usage:
2251
2252 =for html <pre>
2253
2254 $model_object -> ignoresigns( ['#','@'] );
2255
2256 my $ignoresigns = $model_object -> ignoresigns;
2257
2258 =for html </pre>
2259
2260 Arguments:
2261
2262 The argument is an unnamed array of strings
2263
2264 Description:
2265
2266 If ignoresigns is used without argument the string that specifies
2267 which string that is used for comment rows in the data file is
2268 returned. The returned value is an array including the ignore signs
2269 of each problem.  If an argument is given it must be an array of
2270 length equal to the number of problems in the model. Then the names of
2271 the extra data files will be changed to those in the array.
2272
2273 =cut
2274
2275 start ignoresigns
2276       {
2277         # Usage:
2278         #
2279         #   @ignore_signs = @{$modelObject -> ignoresigns( problem_numbers => [2,4] )};
2280         #
2281         # ignoresigns returns the ignore signs in the datafile for the
2282         # specified problems
2283
2284         foreach my $prob ( @{$self -> {'problems'}} ) {
2285           my @datarecs = @{$prob -> datas};
2286           if ( defined $datarecs[0] ) {
2287             push( @ignore, $datarecs[0] -> ignoresign );
2288           } else {
2289             push( @ignore, '#' );
2290           }
2291         }
2292
2293 #       print "IGNORE: @ignore\n";
2294
2295       }
2296 end ignoresigns
2297
2298 # }}} ignoresigns
2299
2300 # {{{ ignore_lists
2301
2302 start ignore_lists
2303       {
2304         # Usage:
2305         #
2306         #   @ignore_signs = @{$modelObject -> ignore_lists( problem_numbers => [2,4] )};
2307         #
2308         # ignore_lists returns the ignore signs in the datafile for the
2309         # specified problems
2310
2311         foreach my $prob ( @{$self -> {'problems'}} ) {
2312           my @datarecs = @{$prob -> datas};
2313           if ( defined $datarecs[0] ) {
2314             push( @ignore, $datarecs[0] -> ignore_list );
2315           } else {
2316             push( @ignore, '#' );
2317           }
2318         }
2319
2320 #       print "IGNORE: @ignore\n";
2321
2322       }
2323 end ignore_lists
2324
2325 # }}} ignoresigns
2326
2327 # {{{ indexes
2328
2329 =head2 fractions
2330
2331 Usage:
2332
2333 =for html <pre>
2334
2335 my $fractions = $model_object -> fractions;
2336
2337 =for html </pre>
2338
2339 Arguments:
2340
2341 =over 2
2342
2343 =item colunm
2344
2345 number
2346
2347 =item column_head
2348
2349 string
2350
2351 =item problem_number
2352
2353 integer
2354
2355 =item return_occurences
2356
2357 boolean
2358
2359 =item ignore_missing
2360
2361 boolean
2362
2363 =back
2364
2365 Description:
2366
2367 fractions will return the fractions from data::fractions. It will find
2368 "column_head" in the $INPUT record instead of that data header as
2369 data::fractions does.
2370
2371 =cut
2372
2373 start indexes
2374       {
2375         # Usage:
2376         #
2377         #   @indexArray = @{$modelObject -> indexes( 'parameter_type' => 'omega' )};
2378         #
2379         # A call to I<indexes> returns the indexes of all parameters
2380         # specified in I<parameter_numbers> from the subproblems
2381         # specified in I<problem_numbers>. The method returns a reference to an array that has
2382         # the same structure as parameter_numbers but for each
2383         # array of numbers is instead an array of indices. The method
2384         # uses a method from the model::problem class to format the
2385         # indices, so here are a few lines from the code comments in
2386         # model/problem.pm that describes the returned value:
2387         #
2388         # <snip>
2389         # The Indexes method calculates the index for a
2390         # parameter. Off-diagonal elements will get a index 'i_j', where i
2391         # is the row number and j is the column number
2392         # </snip>
2393
2394         unless( $#problem_numbers > 0 ){
2395           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
2396         }
2397         my @problems = @{$self -> {'problems'}};
2398         foreach my $i ( @problem_numbers ) {
2399           if ( defined $problems[ $i-1 ] ) {
2400             push( @indexes,
2401                   $problems[ $i-1 ] ->
2402                   indexes( parameter_type => $parameter_type,
2403                            parameter_numbers => $parameter_numbers[ $i-1 ] ) );
2404           } else {
2405             'debug' -> die( message => "Problem number $i does not exist!" );
2406           }
2407         }
2408       }
2409 end indexes
2410
2411 # }}} indexes
2412
2413 # {{{ initial_values
2414
2415 =head2 fractions
2416
2417 Usage:
2418
2419 =for html <pre>
2420
2421 my $fractions = $model_object -> fractions;
2422
2423 =for html </pre>
2424
2425 Arguments:
2426
2427 =over 2
2428
2429 =item colunm
2430
2431 number
2432
2433 =item column_head
2434
2435 string
2436
2437 =item problem_number
2438
2439 integer
2440
2441 =item return_occurences
2442
2443 boolean
2444
2445 =item ignore_missing
2446
2447 boolean
2448
2449 =back
2450
2451 Description:
2452
2453 fractions will return the fractions from data::fractions. It will find
2454 "column_head" in the $INPUT record instead of that data header as
2455 data::fractions does.
2456
2457 =cut
2458
2459 start initial_values
2460       {
2461           # initial_values either sets or gets the initial values of
2462           # the parameter specified in "parameter_type" for each
2463           # problem specified in problem_numbers. For each element
2464           # in problem_numbers there must be a reference in
2465           # parameter_numbers to an array that specify the indices
2466           # of the parameters in the subproblem for which the initial
2467           # values are set, replaced or retrieved.
2468           #
2469           # The add_if_absent argument tells the method to add an init
2470           # (theta,omega,sigma) if the parameter number points to a
2471           # non-existing parameter with parameter number one higher
2472           # than the highest presently included. Only applicable if
2473           # new_values are set. Valid parameter types are 'theta',
2474           # 'omega' and 'sigma'.
2475
2476         @initial_values = @{ $self -> _init_attr
2477                                  ( parameter_type    => $parameter_type,
2478                                    parameter_numbers => \@parameter_numbers,
2479                                    problem_numbers   => \@problem_numbers,
2480                                    new_values        => \@new_values,
2481                                    attribute         => 'init',
2482                                    add_if_absent     => $add_if_absent )};
2483       }
2484 end initial_values
2485
2486 # }}} initial_values
2487
2488 # {{{ is_option_set
2489
2490
2491 =head2 fractions
2492
2493 Usage:
2494
2495 =for html <pre>
2496
2497 my $fractions = $model_object -> fractions;
2498
2499 =for html </pre>
2500
2501 Arguments:
2502
2503 =over 2
2504
2505 =item colunm
2506
2507 number
2508
2509 =item column_head
2510
2511 string
2512
2513 =item problem_number
2514
2515 integer
2516
2517 =item return_occurences
2518
2519 boolean
2520
2521 =item ignore_missing
2522
2523 boolean
2524
2525 =back
2526
2527 Description:
2528
2529 fractions will return the fractions from data::fractions. It will find
2530 "column_head" in the $INPUT record instead of that data header as
2531 data::fractions does.
2532
2533 =cut
2534
2535 start is_option_set
2536       {
2537         # Usage:
2538         #
2539         # if( $modelObject -> is_option_set( record => 'recordName', name => 'optionName' ) ){
2540         #     print "problem_number 1 has option optionName set in record recordName";
2541         # }
2542         #
2543         # is_option_set checks if an option is set in a given record in given problem.
2544
2545         my ( @problems, @records, @options );
2546         my $accessor = $record.'s';
2547         if ( defined $self -> {'problems'} ) {
2548             @problems = @{$self -> {'problems'}};
2549         } else {
2550           'debug' -> die( message => "No problems defined in model" );
2551         }
2552         unless( defined $problems[$problem_number - 1] ){
2553             'debug' -> warn( level => 2,
2554                            message => "model -> is_option_set: No problem number $problem_number defined in model" );
2555             return 0; # No option can be set if no problem exists.
2556         }
2557
2558         if ( defined $problems[$problem_number - 1] -> $accessor ) {
2559             @records = @{$problems[$problem_number - 1] -> $accessor};
2560         } else {
2561             'debug' -> warn( level => 2,
2562                            message => "model -> is_option_set: No record $record defined" .
2563                            " in problem number $problem_number." );
2564             return 0;
2565         }
2566
2567         unless(defined $records[$instance - 1] ){
2568             'debug' -> warn( level => 2,
2569                            message => "model -> is_option_set: No record instance number $instance defined in model." );
2570             return 0;
2571         }
2572
2573         if ( defined $records[$instance - 1] -> options ) {
2574             @options = @{$records[$instance - 1] -> options};
2575         } else {
2576           'debug' -> warn( level => 2,
2577                            message => "No option defined in record: $record in problem number $problem_number." );
2578             return 0;
2579         }
2580         foreach my $option ( @options ) {
2581             $found = 1 if ( defined $option and $option -> name eq $name );
2582             if( $fuzzy_match ){
2583               if( index( $name, $option -> name ) > -1 ){
2584                 $found = 1;
2585               }
2586             }
2587         }
2588       }
2589 end is_option_set
2590
2591 # }}} is_option_set
2592
2593 # {{{ is_run
2594
2595
2596 =head2 fractions
2597
2598 Usage:
2599
2600 =for html <pre>
2601
2602 my $fractions = $model_object -> fractions;
2603
2604 =for html </pre>
2605
2606 Arguments:
2607
2608 =over 2
2609
2610 =item colunm
2611
2612 number
2613
2614 =item column_head
2615
2616 string
2617
2618 =item problem_number
2619
2620 integer
2621
2622 =item return_occurences
2623
2624 boolean
2625
2626 =item ignore_missing
2627
2628 boolean
2629
2630 =back
2631
2632 Description:
2633
2634 fractions will return the fractions from data::fractions. It will find
2635 "column_head" in the $INPUT record instead of that data header as
2636 data::fractions does.
2637
2638 =cut
2639
2640 start is_run
2641       {
2642         # Usage:
2643         #
2644         # is_run returns true if the outputobject owned by the
2645         # modelobject has valid outpudata either in memory or on disc.
2646         if( defined $self -> {'outputs'} ){
2647           if( @{$self -> {'outputs'}}[0] -> have_output ){
2648             $return_value = 1;
2649           }
2650         } else {
2651           $return_value = 0;
2652         }
2653       }
2654 end is_run
2655 # }}} is_run
2656
2657 # {{{ is_simulation
2658
2659
2660 =head2 fractions
2661
2662 Usage:
2663
2664 =for html <pre>
2665
2666 my $fractions = $model_object -> fractions;
2667
2668 =for html </pre>
2669
2670 Arguments:
2671
2672 =over 2
2673
2674 =item colunm
2675
2676 number
2677
2678 =item column_head
2679
2680 string
2681
2682 =item problem_number
2683
2684 integer
2685
2686 =item return_occurences
2687
2688 boolean
2689
2690 =item ignore_missing
2691
2692 boolean
2693
2694 =back
2695
2696 Description:
2697
2698 fractions will return the fractions from data::fractions. It will find
2699 "column_head" in the $INPUT record instead of that data header as
2700 data::fractions does.
2701
2702 =cut
2703
2704 start is_simulation
2705     {
2706       my $problems = $self -> {'problems'};
2707       if( defined $problems -> [$problem_number - 1] ) {
2708         my $problem = $problems -> [$problem_number - 1];
2709         # If we don't have an ESTIMATION record we are simulating.
2710         $is_sim = 1 unless( defined $problem -> {'estimations'} and
2711                          scalar( @{$problem-> {'estimations'}} ) > 0 );
2712
2713         # If we have a ONLYSIM option in the simulation record.
2714         $is_sim = 1 if( $self -> is_option_set ( name           => 'ONLYSIM',
2715                                                  record         => 'simulation',
2716                                                  problem_number => $problem_number ));
2717
2718         # If max evaluations is zero we are simulating
2719         $is_sim = 1 if( defined $self -> maxeval(problem_numbers => [$problem_number]) and
2720                         defined $self -> maxeval(problem_numbers => [$problem_number])->[0][0] and
2721                         $self -> maxeval(problem_numbers => [$problem_number])->[0][0] == 0 );
2722
2723         # Anything else?
2724
2725         # If non of the above is true, we are estimating.
2726       } else {
2727         'debug' -> warn( level => 1,
2728                          message => 'Problem nr. $problem_number not defined. Assuming no simulation' );
2729         $is_sim = 0;
2730       }
2731     }
2732 end is_simulation
2733
2734 # }}}
2735
2736 # {{{ lower_bounds
2737
2738 =head2 fractions
2739
2740 Usage:
2741
2742 =for html <pre>
2743
2744 my $fractions = $model_object -> fractions;
2745
2746 =for html </pre>
2747
2748 Arguments:
2749
2750 =over 2
2751
2752 =item colunm
2753
2754 number
2755
2756 =item column_head
2757
2758 string
2759
2760 =item problem_number
2761
2762 integer
2763
2764 =item return_occurences
2765
2766 boolean
2767
2768 =item ignore_missing
2769
2770 boolean
2771
2772 =back
2773
2774 Description:
2775
2776 fractions will return the fractions from data::fractions. It will find
2777 "column_head" in the $INPUT record instead of that data header as
2778 data::fractions does.
2779
2780 =cut
2781
2782 start lower_bounds
2783       {
2784           # lower_bounds either sets or gets the initial values of the
2785           # parameter specified in the argument parameter_type for
2786           # each problem specified in problem_numbers. See L</fixed>.
2787
2788         @lower_bounds = @{ $self -> _init_attr
2789                              ( parameter_type    => $parameter_type,
2790                                parameter_numbers => \@parameter_numbers,
2791                                problem_numbers           => \@problem_numbers,
2792                                new_values        => \@new_values,
2793                                attribute         => 'lobnd')};
2794       }
2795 end lower_bounds
2796
2797 # }}} lower_bounds
2798
2799 # {{{ labels
2800
2801 =head2 fractions
2802
2803 Usage:
2804
2805 =for html <pre>
2806
2807 my $fractions = $model_object -> fractions;
2808
2809 =for html </pre>
2810
2811 Arguments:
2812
2813 =over 2
2814
2815 =item colunm
2816
2817 number
2818
2819 =item column_head
2820
2821 string
2822
2823 =item problem_number
2824
2825 integer
2826
2827 =item return_occurences
2828
2829 boolean
2830
2831 =item ignore_missing
2832
2833 boolean
2834
2835 =back
2836
2837 Description:
2838
2839 fractions will return the fractions from data::fractions. It will find
2840 "column_head" in the $INPUT record instead of that data header as
2841 data::fractions does.
2842
2843 =cut
2844
2845 start labels
2846       {
2847         # Usage:
2848         #
2849         #   @labels = @{$modobj -> labels( parameter_type => 'theta' )};
2850         #
2851         # This basic usage takes one arguments and returns matched names and
2852         # estimated values of the specified parameter. The parameter_type argument
2853         # is mandatory. It returns the labels of all parameters of type given by
2854         # $parameter_type.
2855         # @labels will be a two-dimensional array:
2856         # [[label1][label2][label3]...]
2857         #
2858         #   $labels -> labels( parameter_type  => 'theta',
2859         #                      problem_numbers => [2,4] );
2860         #
2861         # To get labels of specific problems, the problem_numbers argument can be used.
2862         # It should be a reference to an array containing the numbers
2863         # of all problems whos labels should be retrieved.
2864         #
2865         #   $modobj -> labels( parameter_type    => 'theta',
2866         #                      problem_numbers   => [2,4],
2867         #                      parameter_numbers => [[1,3][4,6]]);
2868         #
2869         # The retrieval can be even more specific by using the parameter_numbers
2870         # argument. It should be a reference to a two-dimensional array, where
2871         # the inner arrays holds the numbers of the parameters that should be
2872         # fetched. In the example above, parameters one and three from problem two
2873         # plus parameters four and six from problem four are retrieved.
2874         #
2875         #   $modobj -> labels( parameter_type    => 'theta',
2876         #                      problem_numbers   => [2,4],
2877         #                      parameter_numbers => [[1,3][4,6]],
2878         #                      generic           => 1 );
2879         #
2880         # To get generic labels for the parameters - e.g. OM1, OM2_1, OM2 etc -
2881         # set the generic argument to 1.
2882         #
2883         # $modobj -> labels( parameter_type     => 'theta',
2884         #                     problem_numbers   => [2],
2885         #                     parameter_numbers => [[1,3]],
2886         #                     new_values        => [['Volume','Clearance']] );
2887         #
2888         # The new_values argument can be used to give parameters new labels. In
2889         # the above example, parameters one and three in problem two are renamed
2890         # Volume and Clearance.
2891         #
2892
2893         my ( @index, $idx );
2894         @labels = @{ $self -> _init_attr
2895                        ( parameter_type    => $parameter_type,
2896                          parameter_numbers => \@parameter_numbers,
2897                          problem_numbers           => \@problem_numbers,
2898                          new_values        => \@new_values,
2899                          attribute         => 'label' )};
2900
2901         #       foreach my $prl ( @labels ) {
2902         #         foreach my $label ( @{$prl} ) {
2903         #           print "Label: $label\n";
2904         #         }
2905         #       }
2906
2907
2908         @index = @{$self -> indexes( parameter_type => $parameter_type,
2909                                      parameter_numbers => \@parameter_numbers,
2910                                      problem_numbers => \@problem_numbers )};
2911
2912         for ( my $i = 0; $i <= $#labels; $i++ ) {
2913           for ( my $j = 0; $j < scalar @{$labels[$i]}; $j++ ) {
2914             $idx = $index[$i][$j];
2915             $labels[$i][$j] = uc(substr($parameter_type,0,2)).$idx
2916               unless ( defined $labels[$i][$j] and not $generic );
2917           }
2918         }
2919       }
2920 end labels
2921
2922 # }}} labels
2923
2924 # {{{ maxeval
2925
2926 =head2 fractions
2927
2928 Usage:
2929
2930 =for html <pre>
2931
2932 my $fractions = $model_object -> fractions;
2933
2934 =for html </pre>
2935
2936 Arguments:
2937
2938 =over 2
2939
2940 =item colunm
2941
2942 number
2943
2944 =item column_head
2945
2946 string
2947
2948 =item problem_number
2949
2950 integer
2951
2952 =item return_occurences
2953
2954 boolean
2955
2956 =item ignore_missing
2957
2958 boolean
2959
2960 =back
2961
2962 Description:
2963
2964 fractions will return the fractions from data::fractions. It will find
2965 "column_head" in the $INPUT record instead of that data header as
2966 data::fractions does.
2967
2968 =cut
2969
2970 start maxeval
2971       {
2972         # Usage:
2973         #
2974         #   @maxev = @{$modobj -> maxeval};
2975         #
2976         # This basic usage takes no arguments and returns the value of the
2977         # MAXEVAL option in the $ESTIMATION record of each problem.
2978         # @maxev will be a two dimensional array:
2979         # [[maxeval_prob1][maxeval_prob2][maxeval_prob3]...]
2980         #
2981         #   $modobj -> maxeval( new_values => [[0],[999]];
2982         #
2983         # If the new_values argument of maxeval is given, the values of the
2984         # MAXEVAL options will be changed. In this example, MAXEVAL will be
2985         # set to 0 in the first problem and to 999 in the second.
2986         # The number of elements in new_values must match the number of problems
2987         # in the model object $modobj.
2988         #
2989         #   $modobj -> maxeval( new_values => [[0],[999]],
2990         #                       problem_numbers    => [2,4] );
2991         #
2992         # To set the MAXEVAL of specific problems, the problem_numbers argument can
2993         # be used. It should be a reference to an array containing the numbers
2994         # of all problems where the MAXEVAL should be changed or retrieved.
2995         # If specified, the size of new_values must be the same as the size
2996         # of problem_numbers.
2997         #
2998
2999
3000
3001         my ( $val_ref, $junk ) = $self ->
3002           _option_val_pos( name            => 'MAX',
3003                            record_name     => 'estimation',
3004                            problem_numbers => \@problem_numbers,
3005                            new_values      => \@new_values,
3006                            exact_match     => $exact_match );
3007         @values = @{$val_ref};
3008       }
3009 end maxeval
3010
3011 # }}} maxeval
3012
3013 # {{{ median
3014
3015 =head2 fractions
3016
3017 Usage:
3018
3019 =for html <pre>
3020
3021 my $fractions = $model_object -> fractions;
3022
3023 =for html </pre>
3024
3025 Arguments:
3026
3027 =over 2
3028
3029 =item colunm
3030
3031 number
3032
3033 =item column_head
3034
3035 string
3036
3037 =item problem_number
3038
3039 integer
3040
3041 =item return_occurences
3042
3043 boolean
3044
3045 =item ignore_missing
3046
3047 boolean
3048
3049 =back
3050
3051 Description:
3052
3053 fractions will return the fractions from data::fractions. It will find
3054 "column_head" in the $INPUT record instead of that data header as
3055 data::fractions does.
3056
3057 =cut
3058
3059 start median
3060       {
3061         # Calls <I>median</I> on the data object of a specified
3062         # problem. See <I>data -> median</I> for details.
3063         my $column_number;
3064         my $extra_data_column;
3065         if ( defined $column_head ) {
3066           # Check normal data object first
3067           my ( $values_ref, $positions_ref ) = $self ->
3068             _get_option_val_pos ( problem_numbers => [$problem_number],
3069                                   name        => $column_head,
3070                                   record_name => 'input',
3071                                   global_position => 1  );
3072           $column_number = $positions_ref -> [0];
3073           if ( not defined $column_number ) {
3074             # Next, check extra_data
3075             my $extra_data_headers = $self -> extra_data_headers;
3076             if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
3077               for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
3078                 $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
3079               }
3080             }
3081           }
3082           'debug' -> die( message => "Unknown column \"$column_head\"" )
3083               unless ( defined $column_number or defined $extra_data_column );
3084         } else {
3085           $column_number = $column;
3086         }
3087
3088         if ( defined $column_number) {
3089           $median = $self -> {'datas'} -> [$problem_number-1] ->
3090             median( column => $column_number,
3091                     unique_in_individual => $unique_in_individual );
3092         } else {
3093           $median = $self -> {'problems'} -> [$problem_number-1] -> extra_data ->
3094             median( column => $extra_data_column,
3095                     unique_in_individual => $unique_in_individual );
3096         }
3097     }
3098 end median
3099
3100 # }}}
3101
3102 # {{{ max
3103
3104 =head2 fractions
3105
3106 Usage:
3107
3108 =for html <pre>
3109
3110 my $fractions = $model_object -> fractions;
3111
3112 =for html </pre>
3113
3114 Arguments:
3115
3116 =over 2
3117
3118 =item colunm
3119
3120 number
3121
3122 =item column_head
3123
3124 string
3125
3126 =item problem_number
3127
3128 integer
3129
3130 =item return_occurences
3131
3132 boolean
3133
3134 =item ignore_missing
3135
3136 boolean
3137
3138 =back
3139
3140 Description:
3141
3142 fractions will return the fractions from data::fractions. It will find
3143 "column_head" in the $INPUT record instead of that data header as
3144 data::fractions does.
3145
3146 =cut
3147
3148 start max
3149       {
3150         # Calls <I>max</I> on the data object of a specified
3151         # problem. See <I>data -> max</I> for details.
3152         my $column_number;
3153         my $extra_data_column;
3154         if ( defined $column_head ) {
3155           # Check normal data object first
3156           my ( $values_ref, $positions_ref ) = $self ->
3157             _get_option_val_pos ( problem_numbers => [$problem_number],
3158                                   name        => $column_head,
3159                                   record_name => 'input',
3160                                   global_position => 1  );
3161           $column_number = $positions_ref -> [0];
3162           if ( not defined $column_number ) {
3163             # Next, check extra_data
3164             my $extra_data_headers = $self -> extra_data_headers;
3165             if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
3166               for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
3167                 $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
3168               }
3169             }
3170           }
3171           'debug' -> die( message => "Unknown column \"$column_head\"" )
3172               unless ( defined $column_number or defined $extra_data_column );
3173         } else {
3174           $column_number = $column;
3175         }
3176
3177         if ( defined $column_number) {
3178           $max = $self -> {'datas'} -> [$problem_number-1] ->
3179             max( column => $column_number );
3180         } else {
3181           $max = $self -> {'problems'} -> [$problem_number-1] -> extra_data ->
3182             max( column => $extra_data_column );
3183         }
3184       }
3185 end max
3186
3187 # }}}
3188
3189 # {{{ min
3190
3191 =head2 fractions
3192
3193 Usage:
3194
3195 =for html <pre>
3196
3197 my $fractions = $model_object -> fractions;
3198
3199 =for html </pre>
3200
3201 Arguments:
3202
3203 =over 2
3204
3205 =item colunm
3206
3207 number
3208
3209 =item column_head
3210
3211 string
3212
3213 =item problem_number
3214
3215 integer
3216
3217 =item return_occurences
3218
3219 boolean
3220
3221 =item ignore_missing
3222
3223 boolean
3224
3225 =back
3226
3227 Description:
3228
3229 fractions will return the fractions from data::fractions. It will find
3230 "column_head" in the $INPUT record instead of that data header as
3231 data::fractions does.
3232
3233 =cut
3234
3235 start min
3236       {
3237         # Calls <I>min</I> on the data object of a specified
3238         # problem. See <I>data -> min</I> for details.
3239         my $column_number;
3240         my $extra_data_column;
3241         if ( defined $column_head ) {
3242           # Check normal data object first
3243           my ( $values_ref, $positions_ref ) = $self ->
3244             _get_option_val_pos ( problem_numbers => [$problem_number],
3245                                   name        => $column_head,
3246                                   record_name => 'input',
3247                                   global_position => 1  );
3248           $column_number = $positions_ref -> [0];
3249           if ( not defined $column_number ) {
3250             # Next, check extra_data
3251             my $extra_data_headers = $self -> extra_data_headers;
3252             if ( defined $extra_data_headers and defined $extra_data_headers -> [0] ) {
3253               for ( my $i = 1; $i <= scalar @{$extra_data_headers->[0]}; $i++ ) {
3254                 $extra_data_column = $i if ( $column_head eq $extra_data_headers->[0][$i-1] );
3255               }
3256             }
3257           }
3258           'debug' -> die( message => "Unknown column \"$column_head\"" )
3259               unless ( defined $column_number or defined $extra_data_column );
3260         } else {
3261           $column_number = $column;
3262         }
3263
3264         if ( defined $column_number) {
3265           $min = $self -> {'datas'} -> [$problem_number-1] ->
3266             min( column => $column_number );
3267         } else {
3268           $min = $self -> {'problems'} -> [$problem_number-1] -> extra_data ->
3269             min( column => $extra_data_column );
3270         }
3271     }
3272 end min
3273
3274 # }}}
3275
3276 # {{{ name_val
3277
3278 =head2 fractions
3279
3280 Usage:
3281
3282 =for html <pre>
3283
3284 my $fractions = $model_object -> fractions;
3285
3286 =for html </pre>
3287
3288 Arguments:
3289
3290 =over 2
3291
3292 =item colunm
3293
3294 number
3295
3296 =item column_head
3297
3298 string
3299
3300 =item problem_number
3301
3302 integer
3303
3304 =item return_occurences
3305
3306 boolean
3307
3308 =item ignore_missing
3309
3310 boolean
3311
3312 =back
3313
3314 Description:
3315
3316 fractions will return the fractions from data::fractions. It will find
3317 "column_head" in the $INPUT record instead of that data header as
3318 data::fractions does.
3319
3320 =cut
3321
3322 start name_val
3323       {
3324         # Usage:
3325         #
3326         #   @name_val = @{$modobj -> name_val( parameter_type => 'theta' )};
3327         #
3328         # This basic usage takes one arguments and returns matched names and
3329         # estimated values of the specified parameter. The parameter_type argument
3330         # is mandatory.
3331         # The names are taken from
3332         # the labels of the parameters (se the labels method for specifications of
3333         # default labels) and the values are aquired from the output object bound
3334         # to the model object. If no output exists, the name_val method returns
3335         # undef.
3336         # @name_val will be a two-dimensional array of references to hashes using
3337         # the names from each problem as keys:
3338         # [[ref to hash1 ][ref to hash2][ref to hash3]...]
3339         #
3340         #   $modobj -> name_val( parameter_type => 'theta',
3341         #                        problem_numbers        => [2,4] );
3342         #
3343         # To get matched names and values of specific problems, the problem_numbers argument
3344         # can be used. It should be a reference to an array containing the numbers
3345         # of all problems whos names and values should be retrieved.
3346         #
3347         #   $modobj -> name_val( parameter_type    => 'theta',
3348         #                        problem_numbers           => [2,4],
3349         #                        parameter_numbers => [[1,3][4,6]]);
3350         #
3351         # The retrieval can be even more specific by using the parameter_numbers
3352         # argument. It should be a reference to a two-dimensional array, where
3353         # the inner arrays holds the numbers of the parameters that should be
3354         # fetched. In the example above, parameters one and three from problem two
3355         # plus parameters four and six from problem four are retrieved.
3356         #
3357
3358         unless( $#problem_numbers > 0 ){
3359           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
3360         }
3361         my @names = @{$self -> labels( parameter_type    => $parameter_type,
3362                                        parameter_numbers => \@parameter_numbers,
3363                                        problem_numbers           => \@problem_numbers )};
3364         my @values;
3365         if ( defined $self -> outputs -> [0] ) {
3366           my $accessor  = $parameter_type.'s';
3367           @values = @{$self -> outputs -> [0] ->
3368                         $accessor( problems => \@problem_numbers,
3369                                    parameter_numbers => \@parameter_numbers )};
3370           #       my @problems = @{$self -> {'problems'}};
3371           #       foreach my $i ( @problem_numbers ) {
3372           #         if ( defined $problems[ $i-1 ] ) {
3373           #           my $pn_ref = $#parameter_numbers >= 0 ? \@{$parameter_numbers[ $i-1 ]} : [];
3374           #           push( @names_values,
3375           #                 $problems[ $i-1 ] ->
3376           #                 name_val( parameter_type => $parameter_type,
3377           #                           parameter_numbers => $pn_ref ) );
3378           #         } else {
3379           #           die "Model -> name_val: Problem number $i does not exist!\n";
3380           #         }
3381           #       }
3382         }
3383         #       if ( scalar @{$self -> {'outputs'}} > 0 ) {
3384         #         my $outobj = $self -> {'outputs'} -> [0];
3385         #       }
3386
3387         'debug' -> die( message => "The number of problems retrieved from the model" .
3388                         " do not match the ones retrived from the output" ) unless( $#names == $#values );
3389         for( my $i = 0; $i <= $#names; $i++ ) {
3390           'debug' -> die( message => "Problem " . $i+1 .
3391                           " The number of parameters retrieved from the model (".scalar @{$names[$i]}.
3392                           ") do not match the ones retrived from the output (".
3393                           scalar @{$values[$i][0]}.")" )
3394                           unless( scalar @{$names[$i]} == scalar @{$values[$i][0]} );
3395           my @prob_nv = ();
3396           for( my $j = 0; $j < scalar @{$values[$i]}; $j++ ){
3397             my %nv = ();
3398             for( my $k = 0; $k < scalar @{$names[$i]}; $k++ ){
3399               $nv{$names[$i][$k]} = $values[$i][$j][$k];
3400             }
3401             push( @prob_nv, \%nv );
3402           }
3403           push( @names_values, \@prob_nv );
3404         }
3405       }
3406 end name_val
3407
3408 # }}} name_val
3409
3410 # {{{ nproblems
3411
3412 =head2 fractions
3413
3414 Usage:
3415
3416 =for html <pre>
3417
3418 my $fractions = $model_object -> fractions;
3419
3420 =for html </pre>
3421
3422 Arguments:
3423
3424 =over 2
3425
3426 =item colunm
3427
3428 number
3429
3430 =item column_head
3431
3432 string
3433
3434 =item problem_number
3435
3436 integer
3437
3438 =item return_occurences
3439
3440 boolean
3441
3442 =item ignore_missing
3443
3444 boolean
3445
3446 =back
3447
3448 Description:
3449
3450 fractions will return the fractions from data::fractions. It will find
3451 "column_head" in the $INPUT record instead of that data header as
3452 data::fractions does.
3453
3454 =cut
3455
3456 start nproblems
3457       {
3458         # nproblems returns the number of problems in the modelobject.
3459
3460         $number_of_problem = scalar @{$self -> {'problems'}};
3461       }
3462 end nproblems
3463
3464 # }}} nproblems
3465
3466 # {{{ nthetas
3467
3468 =head2 fractions
3469
3470 Usage:
3471
3472 =for html <pre>
3473
3474 my $fractions = $model_object -> fractions;
3475
3476 =for html </pre>
3477
3478 Arguments:
3479
3480 =over 2
3481
3482 =item colunm
3483
3484 number
3485
3486 =item column_head
3487
3488 string
3489
3490 =item problem_number
3491
3492 integer
3493
3494 =item return_occurences
3495
3496 boolean
3497
3498 =item ignore_missing
3499
3500 boolean
3501
3502 =back
3503
3504 Description:
3505
3506 fractions will return the fractions from data::fractions. It will find
3507 "column_head" in the $INPUT record instead of that data header as
3508 data::fractions does.
3509
3510 =cut
3511
3512 start nthetas
3513       {
3514           # returns the number of thetas in the model for the given
3515           # problem number.
3516         $nthetas = $self -> _parameter_count( 'record' => 'theta', 'problem_number' => $problem_number );
3517       }
3518 end nthetas
3519
3520 # }}} nthetas
3521
3522 # {{{ nomegas
3523
3524 =head2 fractions
3525
3526 Usage:
3527
3528 =for html <pre>
3529
3530 my $fractions = $model_object -> fractions;
3531
3532 =for html </pre>
3533
3534 Arguments:
3535
3536 =over 2
3537
3538 =item colunm
3539
3540 number
3541
3542 =item column_head
3543
3544 string
3545
3546 =item problem_number
3547
3548 integer
3549
3550 =item return_occurences
3551
3552 boolean
3553
3554 =item ignore_missing
3555
3556 boolean
3557
3558 =back
3559
3560 Description:
3561
3562 fractions will return the fractions from data::fractions. It will find
3563 "column_head" in the $INPUT record instead of that data header as
3564 data::fractions does.
3565
3566 =cut
3567
3568 start nomegas
3569       {
3570           # returns the number of omegas in the model for the given
3571           # problem number.
3572 #       $nomegas = $self -> _parameter_count( 'record' => 'omega', 'problem_number' => $problem_number );
3573         unless( $#problem_numbers >= 0 ){
3574           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
3575         }
3576
3577         my @problems = @{$self -> {'problems'}};
3578         foreach my $i ( @problem_numbers ) {
3579           if ( defined $problems[ $i-1 ] ) {
3580             push( @nomegas, $problems[ $i-1 ] -> nomegas( with_correlations => $with_correlations ));
3581           } else {
3582             'debug' -> die( "Problem number $i does not exist." );
3583           }
3584         }
3585       }
3586 end nomegas
3587
3588 # }}} nomegas
3589
3590 # {{{ nsigmas
3591
3592 =head2 fractions
3593
3594 Usage:
3595
3596 =for html <pre>
3597
3598 my $fractions = $model_object -> fractions;
3599
3600 =for html </pre>
3601
3602 Arguments:
3603
3604 =over 2
3605
3606 =item colunm
3607
3608 number
3609
3610 =item column_head
3611
3612 string
3613
3614 =item problem_number
3615
3616 integer
3617
3618 =item return_occurences
3619
3620 boolean
3621
3622 =item ignore_missing
3623
3624 boolean
3625
3626 =back
3627
3628 Description:
3629
3630 fractions will return the fractions from data::fractions. It will find
3631 "column_head" in the $INPUT record instead of that data header as
3632 data::fractions does.
3633
3634 =cut
3635
3636 start nsigmas
3637
3638 # returns the number of sigmas in the model for the given problem number.
3639
3640 #       $nsigmas = $self -> _parameter_count( 'record' => 'sigma', 'problem_number' => $problem_number );
3641
3642 unless( $#problem_numbers >= 0 ){
3643   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
3644 }
3645
3646 my @problems = @{$self -> {'problems'}};
3647 foreach my $i ( @problem_numbers ) {
3648   if ( defined $problems[ $i-1 ] ) {
3649     push( @nsigmas, $problems[ $i-1 ] -> nsigmas( with_correlations => $with_correlations ));
3650   } else {
3651     'debug' -> die( "Problem number $i does not exist." );
3652   }
3653 }
3654
3655 end nsigmas
3656
3657 # }}} nsigmas
3658
3659 # {{{ outputfile
3660
3661 =head2 fractions
3662
3663 Usage:
3664
3665 =for html <pre>
3666
3667 my $fractions = $model_object -> fractions;
3668
3669 =for html </pre>
3670
3671 Arguments:
3672
3673 =over 2
3674
3675 =item colunm
3676
3677 number
3678
3679 =item column_head
3680
3681 string
3682
3683 =item problem_number
3684
3685 integer
3686
3687 =item return_occurences
3688
3689 boolean
3690
3691 =item ignore_missing
3692
3693 boolean
3694
3695 =back
3696
3697 Description:
3698
3699 fractions will return the fractions from data::fractions. It will find
3700 "column_head" in the $INPUT record instead of that data header as
3701 data::fractions does.
3702
3703 =cut
3704
3705 start outputfile
3706       {
3707         # Usage:
3708         #
3709         # This method is a (partially) automatically generated accessor for the
3710         # outputfile attribute of the model class. Since no named argument is needed
3711         # for accessors, the two possible ways of calling outputfile are:
3712         #
3713         #   $modelObject -> outputfile( 'newfilename.lst' );
3714         #
3715         #   $outputfilename = $modelObject -> outputfile;
3716         #
3717         # The first alternative sets a new name for the output file, and the second
3718         # retrieves the value.
3719         #
3720         # The extra feature for this accessor, compared to other accessors, is that
3721         # if a new name is given, the accessor tries to create a new output object
3722         # based on this.
3723
3724         if( defined $parm ) {
3725           $self -> {'outputs'} =
3726             [ output ->
3727               new( filename             => $parm,
3728                    ignore_missing_files => ( $self -> ignore_missing_files() || $self -> ignore_missing_output_files() ),
3729                    target               => $self -> target(),
3730                    model_id             => $self -> model_id() ) ];
3731         }
3732       }
3733 end outputfile
3734
3735 # }}} outputfile
3736
3737 # {{{ pk
3738
3739 =head2 fractions
3740
3741 Usage:
3742
3743 =for html <pre>
3744
3745 my $fractions = $model_object -> fractions;
3746
3747 =for html </pre>
3748
3749 Arguments:
3750
3751 =over 2
3752
3753 =item colunm
3754
3755 number
3756
3757 =item column_head
3758
3759 string
3760
3761 =item problem_number
3762
3763 integer
3764
3765 =item return_occurences
3766
3767 boolean
3768
3769 =item ignore_missing
3770
3771 boolean
3772
3773 =back
3774
3775 Description:
3776
3777 fractions will return the fractions from data::fractions. It will find
3778 "column_head" in the $INPUT record instead of that data header as
3779 data::fractions does.
3780
3781 =cut
3782
3783 start pk
3784       {
3785         # sets or gets the pk code for a given problem in the
3786         # model object. The new_pk argument should be an array where
3787         # each element contains a row of a valid NONMEM $PK block,
3788
3789         my @prob = @{$self -> problems};
3790
3791         unless( defined $prob[$problem_number - 1] ){
3792           'debug' -> die( message => "Problem number $problem_number does not exist" );
3793         }
3794
3795         my $pks = $prob[$problem_number - 1] -> pks;
3796         if( scalar @new_pk > 0 ) {
3797           if( defined $pks and scalar @{$pks} > 0 ){
3798             $prob[$problem_number - 1] -> pks -> [0] -> code(\@new_pk);
3799           } else {
3800             'debug' -> die( message => "No \$PK record" );
3801           }
3802         } else {
3803           if ( defined $pks and scalar @{$pks} > 0 ) {
3804             @pk = @{$prob[$problem_number - 1] -> pks -> [0] -> code};
3805           }
3806         }
3807       }
3808 end pk
3809
3810 # }}} pk
3811
3812 # {{{ pred
3813
3814 =head2 fractions
3815
3816 Usage:
3817
3818 =for html <pre>
3819
3820 my $fractions = $model_object -> fractions;
3821
3822 =for html </pre>
3823
3824 Arguments:
3825
3826 =over 2
3827
3828 =item colunm
3829
3830 number
3831
3832 =item column_head
3833
3834 string
3835
3836 =item problem_number
3837
3838 integer
3839
3840 =item return_occurences
3841
3842 boolean
3843
3844 =item ignore_missing
3845
3846 boolean
3847
3848 =back
3849
3850 Description:
3851
3852 fractions will return the fractions from data::fractions. It will find
3853 "column_head" in the $INPUT record instead of that data header as
3854 data::fractions does.
3855
3856 =cut
3857
3858 start pred
3859       {
3860         # Sets or gets the pred code for a given problem in the model
3861         # object. See L</pk> for details.
3862         my @prob = @{$self -> problems};
3863
3864         unless( defined $prob[$problem_number - 1] ){
3865           'debug' -> die( message => "problem number $problem_number does not exist" );
3866         }
3867
3868         if( scalar @new_pred > 0 ) {
3869           if( defined $prob[$problem_number - 1] -> preds ){
3870             $prob[$problem_number - 1] -> preds -> [0] -> code(\@new_pred);
3871           } else {
3872             'debug' -> die( message => "No \$PRED record" );
3873           }
3874         } else {
3875           if ( defined $prob[$problem_number - 1] -> preds ) {
3876             @pred = @{$prob[$problem_number - 1] -> preds -> [0] -> code};
3877           } else {
3878             'debug' -> die( message => "No \$PRED record" );
3879           }
3880         }
3881       }
3882 end pred
3883
3884 # }}} pred
3885
3886 # {{{ print
3887
3888 =head2 fractions
3889
3890 Usage:
3891
3892 =for html <pre>
3893
3894 my $fractions = $model_object -> fractions;
3895
3896 =for html </pre>
3897
3898 Arguments:
3899
3900 =over 2
3901
3902 =item colunm
3903
3904 number
3905
3906 =item column_head
3907
3908 string
3909
3910 =item problem_number
3911
3912 integer
3913
3914 =item return_occurences
3915
3916 boolean
3917
3918 =item ignore_missing
3919
3920 boolean
3921
3922 =back
3923
3924 Description:
3925
3926 fractions will return the fractions from data::fractions. It will find
3927 "column_head" in the $INPUT record instead of that data header as
3928 data::fractions does.
3929
3930 =cut
3931
3932 start print
3933       {
3934         # Prints the formatted model to standard out.
3935
3936         my ( @formatted );
3937         foreach my $problem ( @{$self -> {'problems'}} ) {
3938             foreach my $line (@{$problem-> _format_problem}){
3939                 print $line;
3940             }
3941         }
3942       }
3943 end print
3944
3945 # }}} print
3946
3947 # {{{ problem_structure
3948
3949 start problem_structure
3950
3951 my ( $val, $pos ) = $self -> _option_val_pos( record_name => 'simulation',
3952                                               name        => 'SUBPROBLEMS' );
3953 if( defined $val ) {
3954   my @vals = @{$val};
3955   for( my $i = 0; $i <= $#vals; $i++ ) {
3956     if( defined $vals[$i] ) {
3957       if( scalar @{$vals[$i]} > 0 ) {
3958         $subproblems[$i] = $vals[$i][0];
3959       } else {
3960         $subproblems[$i] = 1;
3961       }
3962     } else {
3963       $subproblems[$i] = 1;
3964     }
3965   }
3966 }
3967
3968 end problem_structure
3969
3970 # }}} problem_structure
3971
3972 # {{{ randomize_inits
3973
3974 =head2 fractions
3975
3976 Usage:
3977
3978 =for html <pre>
3979
3980 my $fractions = $model_object -> fractions;
3981
3982 =for html </pre>
3983
3984 Arguments:
3985
3986 =over 2
3987
3988 =item colunm
3989
3990 number
3991
3992 =item column_head
3993
3994 string
3995
3996 =item problem_number
3997
3998 integer
3999
4000 =item return_occurences
4001
4002 boolean
4003
4004 =item ignore_missing
4005
4006 boolean
4007
4008 =back
4009
4010 Description:
4011
4012 fractions will return the fractions from data::fractions. It will find
4013 "column_head" in the $INPUT record instead of that data header as
4014 data::fractions does.
4015
4016 =cut
4017
4018 start randomize_inits
4019       {
4020         foreach my $prob ( @{$self -> {'problems'}} ) {
4021           $prob -> set_random_inits ( degree => $degree );
4022         }
4023       }
4024 end randomize_inits
4025
4026 # }}}
4027
4028 # {{{ record
4029
4030 =head2 fractions
4031
4032 Usage:
4033
4034 =for html <pre>
4035
4036 my $fractions = $model_object -> fractions;
4037
4038 =for html </pre>
4039
4040 Arguments:
4041
4042 =over 2
4043
4044 =item colunm
4045
4046 number
4047
4048 =item column_head
4049
4050 string
4051
4052 =item problem_number
4053
4054 integer
4055
4056 =item return_occurences
4057
4058 boolean
4059
4060 =item ignore_missing
4061
4062 boolean
4063
4064 =back
4065
4066 Description:
4067
4068 fractions will return the fractions from data::fractions. It will find
4069 "column_head" in the $INPUT record instead of that data header as
4070 data::fractions does.
4071
4072 =cut
4073
4074 start record
4075      {
4076          # If the argument new_data is given, record sets new_data in
4077          # the model objects member specified with record_name. The
4078          # format of new_data is an array of strings, where each
4079          # element corresponds to a line of code as it would have
4080          # looked like in a valid NONMEM modelfile. If new_data is left
4081          # undefined, record returns lines of code belonging to the
4082          # record specified by record_name in a format that is valid in
4083          # a NONMEM modelfile.
4084
4085          my @problems = @{$self -> {'problems'}};
4086          my $records;
4087
4088          if ( defined $problems[ $problem_number - 1 ] ) {
4089              if ( scalar(@new_data) > 0 ){
4090                  my $rec_class = "model::problem::$record_name";
4091                  my $record = $rec_class -> new('record_arr' => \@new_data );
4092              } else {
4093                  $record_name .= 's';
4094                  $records = $problems[ $problem_number - 1 ] -> {$record_name};
4095                  foreach my $record( @{$records} ){
4096                      push(@data, $record -> _format_record);
4097                  }
4098              }
4099          }
4100      }
4101 end record
4102
4103 # }}} record
4104
4105 # {{{ remove_inits
4106
4107 =head2 fractions
4108
4109 Usage:
4110
4111 =for html <pre>
4112
4113 my $fractions = $model_object -> fractions;
4114
4115 =for html </pre>
4116
4117 Arguments:
4118
4119 =over 2
4120
4121 =item colunm
4122
4123 number
4124
4125 =item column_head
4126
4127 string
4128
4129 =item problem_number
4130
4131 integer
4132
4133 =item return_occurences
4134
4135 boolean
4136
4137 =item ignore_missing
4138
4139 boolean
4140
4141 =back
4142
4143 Description:
4144
4145 fractions will return the fractions from data::fractions. It will find
4146 "column_head" in the $INPUT record instead of that data header as
4147 data::fractions does.
4148
4149 =cut
4150
4151 start remove_inits
4152     {
4153       # Usage
4154       #
4155       # $model -> remove_inits( type => 'theta',
4156       #                         indexes => [1,2,5,6] )
4157       #
4158
4159       # In all cases the type must be set to theta. Removing Omegas in
4160       # Sigmas is not allowed, (If need that feature, send us a
4161       # mail). In the above example the thetas 1, 2, 5 and 6 will be
4162       # removed from the modelfile. Notice that this alters the theta
4163       # numbering, so if you later decide that theta number 7 must be
4164       # removed as well, you must calculate its new position in the
4165       # file. In this case the new number would be 3. Also notice that
4166       # numbering starts with 1.
4167       #
4168       # $model -> remove_inits( type => 'theta',
4169       #                         labels => ['V', 'CL'] )
4170       #
4171
4172       # If you have specified labels in you modelfiles(a label is
4173       # string inside a comment on the same row as the theta) you can
4174       # specify an array with labels, and the corresponding theta, if
4175       # it exists, will be removed. This is a much better approach
4176       # since you don't need to know where in order the theta you wish
4177       # to remove appears. If you specify both labels and indexes, the
4178       # indexes will be ignored.
4179
4180       'debug' -> die( message => 'does not have the functionality for removing $OMEGA or $SIGMA options yet' )
4181           if ( $type eq 'omega' or $type eq 'sigma' );
4182       my $accessor = $type.'s';
4183
4184       # First pick out a referens to the theta records array.
4185       my $inits_ref = $self -> problems -> [$problem_number -1] -> $accessor;
4186
4187       # If we have any thetas at all:
4188       if ( defined $inits_ref ) {
4189         my @inits = @{$inits_ref};
4190
4191         # If labels are specified, we translate the labels into
4192         # indexes.
4193         if ( scalar @labels > 0 ) {
4194           @indexes = ();
4195           my $i = 1;
4196           # Loop over theta records
4197           foreach my $init ( @inits ) {
4198             # Loop over the individual thetas inside
4199             foreach my $option ( @{$init -> options} ) {
4200               # Loop over all given labels.
4201               foreach my $label ( @labels ) {
4202                 # Push the index number if a given label match the
4203                 # theta label
4204                 push( @indexes, $i ) if ( $option -> label eq $label);
4205               }
4206               # $i is the count of thetas so far
4207               $i++;
4208             }
4209           }
4210         }
4211
4212         # We don't really remove thetas, we do a loop over all thetas
4213         # and recording which we like to keep. We do that by selecting
4214         # an index, from @indexes, that shall be removed and loop over
4215         # the thetas, all thetas that doesn't match the index are
4216         # stored in @keep_options. When we find a theta that matches,
4217         # we pick a new index and continue the loop. So by makeing
4218         # sure that @indexes is sorted, we only need to loop over the
4219         # thetas once.
4220
4221         @indexes = sort {$a <=> $b} @indexes;
4222
4223         my $index = 0;
4224         my $nr_options = 1;
4225         my @keep_records;
4226
4227         # Loop over all records
4228         RECORD_LOOP: foreach my $record ( @inits ){
4229           my @keep_options = ();
4230           # Loop over all thetas
4231           foreach my $option ( @{$record -> options} ) {
4232             if( $indexes[ $index ] == $nr_options ){
4233               # If a theta matches an index, we take the next index
4234               # and forget the theta.
4235               unless( $index > $#indexes ){
4236                 $index++;
4237               }
4238             } else {
4239               # Otherwise we rember it.
4240               push(@keep_options,$option);
4241             }
4242             $nr_options++;
4243           }
4244           if( scalar(@keep_options) > 0 ){
4245             # If we remember some thetas, we must also remember the
4246             # record which they are in.
4247             $record -> options( \@keep_options );
4248             push( @keep_records, $record );
4249           }
4250         }
4251
4252         # Set the all kept thetas back into the modelobject.
4253         @{$inits_ref} = @keep_records;
4254
4255       } else {
4256         'debug' -> die( message => "No init of type $type defined" );
4257       }
4258     }
4259 end remove_inits
4260
4261 # }}}
4262
4263 # {{{ restore_inits
4264
4265 =head2 fractions
4266
4267 Usage:
4268
4269 =for html <pre>
4270
4271 my $fractions = $model_object -> fractions;
4272
4273 =for html </pre>
4274
4275 Arguments:
4276
4277 =over 2
4278
4279 =item colunm
4280
4281 number
4282
4283 =item column_head
4284
4285 string
4286
4287 =item problem_number
4288
4289 integer
4290
4291 =item return_occurences
4292
4293 boolean
4294
4295 =item ignore_missing
4296
4297 boolean
4298
4299 =back
4300
4301 Description:
4302
4303 fractions will return the fractions from data::fractions. It will find
4304 "column_head" in the $INPUT record instead of that data header as
4305 data::fractions does.
4306
4307 =cut
4308
4309 start restore_inits
4310       {
4311         # restore_inits brings back initial values previously stored
4312         # using store_inits. This method pair allows a user to store
4313         # the currents initial values in a backup, replace them with
4314         # temporary values and later restore them.
4315
4316         if ( defined $self -> {'problems'} ) {
4317           foreach my $problem ( @{$self -> {'problems'}} ){
4318             $problem -> restore_inits;
4319           }
4320         }
4321       }
4322 end restore_inits
4323
4324 # }}} restore_inits
4325
4326 # {{{ store_inits
4327
4328 =head2 fractions
4329
4330 Usage:
4331
4332 =for html <pre>
4333
4334 my $fractions = $model_object -> fractions;
4335
4336 =for html </pre>
4337
4338 Arguments:
4339
4340 =over 2
4341
4342 =item colunm
4343
4344 number
4345
4346 =item column_head
4347
4348 string
4349
4350 =item problem_number
4351
4352 integer
4353
4354 =item return_occurences
4355
4356 boolean
4357
4358 =item ignore_missing
4359
4360 boolean
4361
4362 =back
4363
4364 Description:
4365
4366 fractions will return the fractions from data::fractions. It will find
4367 "column_head" in the $INPUT record instead of that data header as
4368 data::fractions does.
4369
4370 =cut
4371
4372 start store_inits
4373       {
4374         # store_inits stores initial values that can later be
4375         # brought back using restore_inits. See L</restore_inits>.
4376
4377         if ( defined $self -> {'problems'} ) {
4378           foreach my $problem ( @{$self -> {'problems'}} ){
4379             $problem -> store_inits;
4380           }
4381         }
4382       }
4383 end store_inits
4384
4385 # }}} store_inits
4386
4387 # {{{ synchronize
4388
4389 start synchronize
4390       {
4391           # Synchronize checks the I<synced> object attribute to see
4392           # if the model is in sync with its corresponding file, given
4393           # by the objetc attribute I<filename>. If not, it checks if
4394           # the model contains any defined problems and if it does, it
4395           # writes the formatted model to disk, overwriting any
4396           # existing file of name I<filename>. If no problem is
4397           # defined, synchronize tries to parse the file I<filename>
4398           # and set the object internals to match it.
4399         unless( $self -> {'synced'} ){
4400           if( defined $self -> {'problems'} and
4401               scalar @{$self -> {'problems'}} > 0 ){
4402             $self -> _write;
4403           } else {
4404             if( -e $self -> full_name ){
4405               $self -> _read_problems;
4406             } else {
4407               return;
4408             }
4409           }
4410         }
4411         $self -> {'synced'} = 1;
4412       }
4413 end synchronize
4414
4415 # }}} synchronize
4416
4417 # {{{ flush
4418 start flush
4419       # synchronizes the object with the file on disk and empties
4420       # most of the objects attributes to save memory.
4421       if( defined $self -> {'problems'} and
4422           ( !$self -> {'synced'} or $force ) ) {
4423         $self -> _write;
4424       }
4425       $self -> {'problems'} = undef;
4426       $self -> {'synced'} = 0;
4427
4428 end flush
4429 # }}} flush
4430
4431 # {{{ target
4432 start target
4433       {
4434         if ( $parm eq 'disk' ) {
4435           $self -> {'target'} = 'disk';
4436           $self -> flush;
4437         } elsif ( $parm eq 'mem' and $self -> {'target'} eq 'disk' ) {
4438           $self -> {'target'} = 'mem';
4439           $self -> synchronize;
4440         }
4441       }
4442 end target
4443 # }}}
4444
4445 # {{{ msfi_names
4446
4447 =head2 msfi_names
4448
4449 Usage:
4450
4451 =for html <pre>
4452
4453 my $msfi_names_ref = $model_object -> msfi_names;
4454
4455 =for html </pre>
4456
4457 Arguments:
4458
4459 =over 2
4460
4461 =item new_names
4462
4463 array of strings
4464
4465 =item problem_numbers
4466
4467 array of integers
4468
4469 =item ignore_missing_files
4470
4471 boolean
4472
4473 =back
4474
4475 Description:
4476
4477 msfi_names will return the names of all MSFI= statements in the
4478 $ESTIMATION records in all problems.
4479
4480 =cut
4481
4482 start msfi_names
4483 # Usage:
4484 #
4485 #    @msfiNames = @{$modobj -> msfi_names};
4486 #
4487 #    or better:
4488 #
4489 #    $msfiNamesRef = $modobj -> msfi_names;
4490 #    @msfiNames = @{$msfiNamesRef} if (defined $msfiNamesRef);
4491 #
4492 # This basic usage takes no arguments and returns the value of
4493 # the MSFI option in the $ESTIMATION NONMEM record of each
4494 # problem. @msfiNames will be a two-dimensional array:
4495 #
4496 #   [[msfiName_prob1],[msfiName_prob2],[msfiName_prob3]...]
4497 #
4498
4499 my @problems;
4500 if ( defined $self -> problems() ) {
4501   @problems = @{$self -> problems()};
4502 } else {
4503   'debug' -> die( message => "No problems defined in model" );
4504 }
4505
4506 if( scalar @new_names > 0 ) {
4507   my $i = 0;
4508   foreach my $prob ( @problems ) {
4509     $prob -> remove_records( type => 'msfi' );
4510     if( defined $new_names[$i] ) {
4511       $prob -> add_records( type           => 'msfi',
4512                             record_strings => [$new_names[$i]] );
4513     }
4514   }
4515 } else {
4516   foreach my $prob ( @problems ) {
4517     if ( defined $prob -> msfis() ) {
4518       my @instances = @{$prob -> msfis()};
4519       my @prob_names;
4520       foreach my $instance ( @instances ) {
4521         my @options;
4522         if ( defined $instance -> options() ) {
4523           @options = @{$instance -> options()};
4524         }
4525         if ( defined $options[0] ) {
4526           push( @prob_names, $options[0] -> name );
4527         } else {
4528           push( @prob_names, undef );
4529         }
4530       }
4531       push( @names, \@prob_names );
4532     }
4533   }
4534 }
4535
4536 end msfi_names
4537
4538 # }}} msfi_names
4539
4540 # {{{ msfo_names
4541
4542 =head2 msfo_names
4543
4544 Usage:
4545
4546 =for html <pre>
4547
4548 my $msfo_names_ref = $model_object -> msfo_names;
4549
4550 =for html </pre>
4551
4552 Arguments:
4553
4554 =over 2
4555
4556 =item new_names
4557
4558 array of strings
4559
4560 =item problem_numbers
4561
4562 array of integers
4563
4564 =item ignore_missing_files
4565
4566 boolean
4567
4568 =back
4569
4570 Description:
4571
4572 msfo_names will return the names of all MSFO= statements in the
4573 $ESTIMATION records in all problems.
4574
4575 =cut
4576
4577 start msfo_names
4578 # Usage:
4579 #
4580 #    @msfoNames = @{$modobj -> msfo_names};
4581 #
4582 #    or better:
4583 #
4584 #    $msfoNamesRef = $modobj -> msfo_names;
4585 #    @msfoNames = @{$msfoNamesRef} if (defined $msfoNamesRef);
4586 #
4587 # This basic usage takes no arguments and returns the value of
4588 # the MSFO option in the $ESTIMATION NONMEM record of each
4589 # problem. @msfoNames will be an array:
4590 #
4591 #   [msfoName_prob1,msfoName_prob2,msfoName_prob3...]
4592 #
4593 #
4594 # If the I<new_names> argument of msfo_names is given, the
4595 # values of the MSFO options will be changed.
4596 #
4597 # To set the MSFO of specific problems, the I<problem_numbers>
4598 # argument can be used. It should be a reference to an array
4599 # containing the numbers of all problems where the FILE should
4600 # be changed or retrieved. If specified, the size of
4601 # I<new_names> must be the same as the size of
4602 # I<problem_numbers>.
4603
4604 my ( $name_ref, $junk ) = $self ->
4605     _option_val_pos( name            => 'MSFO',
4606                      record_name     => 'estimation',
4607                      problem_numbers => \@problem_numbers,
4608                      new_values      => \@new_names );
4609
4610
4611 my ( $nonp_name_ref, $junk ) = $self ->
4612     _option_val_pos( name            => 'MSFO',
4613                      record_name     => 'nonparametric',
4614                      problem_numbers => \@problem_numbers,
4615                      new_values      => \@new_names );
4616
4617 if( scalar( @{$name_ref -> [0]} > 0 ) ){
4618   push( @names, @{$name_ref} );
4619 }
4620
4621 if( scalar( @{$nonp_name_ref -> [0]} > 0 ) ){
4622   push( @names, @{$nonp_name_ref} );
4623 }
4624
4625 end msfo_names
4626
4627 # }}} msfo_names
4628
4629 # {{{ table_names
4630
4631 =head2 fractions
4632
4633 Usage:
4634
4635 =for html <pre>
4636
4637 my $fractions = $model_object -> fractions;
4638
4639 =for html </pre>
4640
4641 Arguments:
4642
4643 =over 2
4644
4645 =item colunm
4646
4647 number
4648
4649 =item column_head
4650
4651 string
4652
4653 =item problem_number
4654
4655 integer
4656
4657 =item return_occurences
4658
4659 boolean
4660
4661 =item ignore_missing
4662
4663 boolean
4664
4665 =back
4666
4667 Description:
4668
4669 fractions will return the fractions from data::fractions. It will find
4670 "column_head" in the $INPUT record instead of that data header as
4671 data::fractions does.
4672
4673 =cut
4674
4675 start table_names
4676       {
4677         # Usage:
4678         #
4679         #    @tableNames = @{$modobj -> table_names};
4680         #
4681         # This basic usage takes no arguments and returns the value of
4682         # the FILE option in the $TABLE NONMEM record of each
4683         # problem. @tableNames will be a two dimensional array:
4684         #
4685         #   [[tableName_prob1][tableName_prob2][tableName_prob3]...]
4686         #
4687         #
4688         # If the I<new_names> argument of table_names is given, the
4689         # values of the FILE options will be changed.
4690         #
4691         # To set the FILE of specific problems, the I<problem_numbers>
4692         # argument can be used. It should be a reference to an array
4693         # containing the numbers of all problems where the FILE should
4694         # be changed or retrieved.  If specified, the size of
4695         # I<new_names> must be the same as the size of
4696         # I<problem_numbers>.
4697         #
4698         # The I<ignore_missing_files> boolean argument can be used to
4699         # set names of table that does not exist yet (e.g. before a
4700         # run has been performed).
4701
4702         my ( $name_ref, $junk ) = $self ->
4703           _option_val_pos( name            => 'FILE',
4704                            record_name     => 'table',
4705                            problem_numbers => \@problem_numbers,
4706                            new_values      => \@new_names );
4707         if ( $#new_names >= 0 ) {
4708           my @problems = @{$self -> {'problems'}};
4709           unless( $#problem_numbers > 0 ){
4710             @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
4711           }
4712           foreach my $i ( @problem_numbers ) {
4713             $problems[$i-1] -> _read_table_files( ignore_missing_files => $ignore_missing_files || $self -> {'ignore_missing_output_files'});
4714           }
4715         }
4716         @names = @{$name_ref};
4717       }
4718 end table_names
4719
4720 # }}} table_names
4721
4722 # {{{ table_files
4723
4724 =head2 fractions
4725
4726 Usage:
4727
4728 =for html <pre>
4729
4730 my $fractions = $model_object -> fractions;
4731
4732 =for html </pre>
4733
4734 Arguments:
4735
4736 =over 2
4737
4738 =item colunm
4739
4740 number
4741
4742 =item column_head
4743
4744 string
4745
4746 =item problem_number
4747
4748 integer
4749
4750 =item return_occurences
4751
4752 boolean
4753
4754 =item ignore_missing
4755
4756 boolean
4757
4758 =back
4759
4760 Description:
4761
4762 fractions will return the fractions from data::fractions. It will find
4763 "column_head" in the $INPUT record instead of that data header as
4764 data::fractions does.
4765
4766 =cut
4767
4768 start table_files
4769       {
4770         # Usage:
4771         #
4772         #    @table_files = @{$modobj -> table_files};
4773         #
4774         # This basic usage takes no arguments and returns the table
4775         # files objects for all problems.  @table_files will be a
4776         # two dimensional array:
4777         #
4778         #   [[table_file_object_prob1][table_file_object_prob2]...]
4779         #
4780         #
4781         # To retrieve the table file objects from specific problems,
4782         # the I<problem_numbers> argument can be used. It should be
4783         # a reference to an array containing the numbers of all
4784         # problems from which the table file objects should be
4785         # retrieved.
4786
4787         unless( $#problem_numbers > 0 ){
4788           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
4789         }
4790         my @problems = @{$self -> {'problems'}};
4791         foreach my $i ( @problem_numbers ) {
4792           if ( defined $problems[ $i-1 ] ) {
4793             push( @table_files, $problems[$i-1] -> table_files );
4794           } else {
4795             'debug' -> die( message => "Problem number $i does not exist!" );
4796           }
4797         }
4798       }
4799 end table_files
4800
4801 # }}}
4802
4803 # {{{ units
4804
4805 =head2 fractions
4806
4807 Usage:
4808
4809 =for html <pre>
4810
4811 my $fractions = $model_object -> fractions;
4812
4813 =for html </pre>
4814
4815 Arguments:
4816
4817 =over 2
4818
4819 =item colunm
4820
4821 number
4822
4823 =item column_head
4824
4825 string
4826
4827 =item problem_number
4828
4829 integer
4830
4831 =item return_occurences
4832
4833 boolean
4834
4835 =item ignore_missing
4836
4837 boolean
4838
4839 =back
4840
4841 Description:
4842
4843 fractions will return the fractions from data::fractions. It will find
4844 "column_head" in the $INPUT record instead of that data header as
4845 data::fractions does.
4846
4847 =cut
4848
4849 start units
4850       {
4851           # Sets or gets the units of a (number of) parameter(s). The
4852           # unit is not a proper NONMEM syntax but is recognized by
4853           # the PsN model class. A unit (and a label) can be specified
4854           # as a comments after a parameter definition. e.g.:
4855           #
4856           #    $THETA (0,13.2,100) ; MTT; h
4857           #
4858           # which will give this theta the label I<MTT> and unit I<h>.
4859         @units = @{ $self -> _init_attr( parameter_type    => $parameter_type,
4860                                          parameter_numbers => \@parameter_numbers,
4861                                          problem_numbers           => \@problem_numbers,
4862                                          new_values        => \@new_values,
4863                                          type              => 'unit')};
4864       }
4865 end units
4866
4867 # }}} units
4868
4869 # {{{ update_inits
4870
4871
4872 =head2 fractions
4873
4874 Usage:
4875
4876 =for html <pre>
4877
4878 my $fractions = $model_object -> fractions;
4879
4880 =for html </pre>
4881
4882 Arguments:
4883
4884 =over 2
4885
4886 =item colunm
4887
4888 number
4889
4890 =item column_head
4891
4892 string
4893
4894 =item problem_number
4895
4896 integer
4897
4898 =item return_occurences
4899
4900 boolean
4901
4902 =item ignore_missing
4903
4904 boolean
4905
4906 =back
4907
4908 Description:
4909
4910 fractions will return the fractions from data::fractions. It will find
4911 "column_head" in the $INPUT record instead of that data header as
4912 data::fractions does.
4913
4914 =cut
4915
4916 start update_inits
4917       {
4918         # Usage:
4919         #
4920         #   $modobj -> update_inits ( from_output => $outobj );
4921         #
4922         # alt
4923         #
4924         #   $modobj -> update_inits ( from_output_file => $outfile );
4925         #
4926         # This basic usage takes the parameter estimates from the
4927         # output object I<$outobj> or from the output file I<$outfile>
4928         # and updates the initial estimates in the model object
4929         # I<$modobj>. The number of problems and parameters must be
4930         # the same in the model and output objects. If there exist
4931         # more than one subproblem per problem in the output object,
4932         # only the estimates from the first subproblem will be
4933         # transferred.
4934         #
4935         #   $modobj -> update_inits ( from_output               => $outobj,
4936         #                             ignore_missing_parameters => 1 );
4937         #
4938         # If the ignore_missing_parameters argument is set to 1, the number of
4939         # parameters in the model and output objects do not need to match. The
4940         # parameters that exist in both objects are used for the update of the
4941         # model object.
4942         #
4943         #   $modobj -> update_inits ( from_output               => $outobj,
4944         #                             from_model                => $from_modobj );
4945         #
4946         # If the from_model argument is given, update_inits tries to match the
4947         # parameter names (labels) given in $from_modobj and $modobj and
4948         # and thereafter updating the $modobj object. See L</units> and L</labels>.
4949         #
4950
4951         my ( %labels, @own_labels, @from_labels );
4952         'debug' -> die( message => "No output object defined and" .
4953                       " no output object found through the model object specified." )
4954             unless ( ( defined $from_model and
4955                        ( defined $from_model -> outputs and
4956                          defined @{$from_model -> outputs}[0] ) ) or
4957                      defined $from_output or
4958                      defined $from_output_file );
4959         if ( defined $from_output ) {
4960           'debug' -> warn( level   => 2,
4961                          message => "using output object ".
4962                          "specified as argument\n" );
4963         } elsif ( defined $from_output_file ) {
4964           $from_output = output -> new( filename             => $from_output_file );
4965         } else {
4966           $from_output = @{$from_model -> outputs}[0];
4967         }
4968
4969         my @params = ();
4970         if( $update_thetas ){
4971           push( @params, 'theta' );
4972         }
4973         if( $update_omegas ) {
4974           push( @params, 'omega' );
4975         }
4976         if( $update_sigmas ) {
4977           push( @params, 'sigma' );
4978         }
4979
4980         foreach my $param ( @params ) {
4981           # Get own labels and from labels
4982           if ( defined $from_model ) {
4983             @own_labels = @{$self -> labels( parameter_type => $param )};
4984
4985             @from_labels = @{$from_model -> labels( parameter_type => $param )};
4986             'debug' -> die( message => "The number of problems are not the same in from-model ".
4987                             $from_model -> full_name." (".
4988                             ($#from_labels+1).")".
4989                             " and the model to be updated ".
4990                             $self -> full_name." (".
4991                             ($#own_labels+1).")" ) unless ( $#own_labels == $#from_labels );
4992           } else {
4993             @own_labels = @{$self -> labels( parameter_type => $param,
4994                                              generic        => 1 )};
4995             @from_labels = @{$from_output -> labels( parameter_type => $param )};
4996             'debug' -> die( message => "The number of problems are not the same in from-output ".
4997                             $from_output -> full_name." (".
4998                             ($#from_labels+1).")".
4999                             " and the model to be updated ".
5000                             $self -> full_name." (".
5001                             ($#own_labels+1).")" ) unless ( $#own_labels == $#from_labels );
5002           }
5003
5004           # Loop over the problems:
5005           my $accessor = $param.'s';
5006           # Since initial estimates are specified on the problem level and not on
5007           # the subproblem level we use the estimates from the outputs first subproblem
5008           my @from_values = @{$from_output -> $accessor ( subproblems => [1] )};
5009           # {{{ Omega and Sigma update section
5010
5011           # The functionality that has been commented out because it
5012           # fails when omegas are zero. This functionality should be
5013           # moved to output::problem::subproblem (2005-02-09) TODO
5014
5015 #         if ($param eq 'omega' or $param eq 'sigma')
5016 #         {
5017 #           #print "FL: ", Dumper @from_labels;
5018 #           #print "OL: ", Dumper @own_labels;
5019 #           print "FV: $param Before " . Dumper(@from_values) . "\n";
5020 #           #Fix omegas and sigmas so that the correlation between elements <=1
5021 #           my $raw_accessor = "raw_" . $accessor;
5022 #           my @raw_from_values = @{$from_output -> $raw_accessor(subproblems => [1])};
5023 #           my ($i,$j);
5024 #           for (my $a=0; $a<scalar(@from_values); $a++)
5025 #           {
5026 #             my $prob_values = $from_values[$a];
5027 #             my $raw_prob_values = $raw_from_values[$a];
5028 #             for (my $b=0; $b<scalar(@{$prob_values}); $b++)
5029 #             {
5030 #               my $values = $prob_values->[$b];
5031 #               my $raw_values = $raw_prob_values->[$b];
5032 #               my $counter = 0;
5033 #               #Find out the n*n-matrix size (pq-formula)
5034 #               my $n = int(sqrt(1/4+scalar(@{$raw_values})*2)-1/2);
5035 #               for ($i=0; $i<$n; $i++)
5036 #               {
5037 #                 for ($j=0; $j<$n; $j++)
5038 #                 {
5039 #                   if ( $j<=$i && $raw_values->[$i*($i+1)/2+$j]!=0 )
5040 #                   {
5041 #                     #print "Omega value = " . @other_val[$counter]  . "\n";
5042 #                     $counter++;
5043 #                   }
5044 #                   #Only check the low-triangular off-diagonals of the omega matrix
5045 #                   #omega(i,j)>=sqrt(omega(i,i)*omega(j,j))
5046 #                   if ($j<=$i && $j!=$i &&
5047 #                       ($raw_values->[$i*($i+1)/2+$j]>=sqrt(
5048 #                                                            $raw_values->[$i*($i+1)/2+$i]*$raw_values->[$j*($j+1)/2+$j])))
5049 #                   {
5050 #                     print "Changing raw value at $i, $j: " . $raw_values->[$i*($i+1)/2+$j] ." to ".
5051 #                         (int(10000*sqrt($raw_values->[$i*($i+1)/2+$i]*$raw_values->[$j*($j+1)/2+$j]))/10000) ."\n";
5052 #                     #print "At index ($i,$j)\n" if ($self->{'debug'});
5053 #                     $raw_values->[$i*($i+1)/2+$j]=int(10000*sqrt(
5054 #                                                                  $raw_values->[$i*($i+1)/2+$i]*$raw_values->[$j*($j+1)/2+$j]))/10000;
5055 #                     print "Changing omega value " . $values->[$counter-1] . " to " . $raw_values->[$i*($i+1)/2+$j] ."\n";
5056 #                     $values->[$counter-1] = $raw_values->[$i*($i+1)/2+$j];
5057 #                   }
5058 #                 }
5059 #               }
5060 #             }
5061 #           }
5062 #           #print "FL: ", Dumper @from_labels;
5063 #           #print "OL: ", Dumper @own_labels;
5064 #           print "FV: $param After ", Dumper(@from_values), "\n";
5065 #           die;
5066 #         }
5067
5068           # }}}
5069
5070           for ( my $i = 0; $i <= $#own_labels; $i++ ) {
5071
5072             if( $from_output -> have_user_defined_prior ){
5073               $ignore_missing_parameters = 1;
5074             }
5075             unless ( $ignore_missing_parameters ) {
5076               my $from_name = defined $from_model ? $from_model -> filename :
5077                 $from_output -> filename;
5078               'debug' -> die( message => "Model -> update_inits: The number of ".$param.
5079                               "s are not the same in from-model (" . $from_name .
5080                               "): " . scalar @{$from_labels[$i]} .
5081                               ", and the model to be updated (" . $self -> {'filename'} .
5082                               "): " . scalar @{$own_labels[$i]} )
5083                   unless ( scalar @{$own_labels[$i]} ==
5084                            scalar @{$from_labels[$i]} );
5085             }
5086
5087             for ( my $j = 0; $j < scalar @{$from_labels[$i]}; $j++ ) {
5088               for ( my $k = 0; $k < scalar @{$own_labels[$i]}; $k++ ) {
5089                 if ( $from_labels[$i][$j] eq $own_labels[$i][$k] ){
5090                   $labels{$k+1} = $from_values[$i][0][$j];
5091                 }
5092               }
5093             }
5094
5095             my @own_idxs = keys( %labels );
5096             my @from_vals;
5097             for(my $i=0; $i <= $#own_idxs; $i++){
5098               @from_vals[$i] = $labels{ $own_idxs[$i] };
5099             }
5100
5101             $self -> initial_values( problem_numbers           => [$i+1],
5102                                      parameter_type    => $param,
5103                                      parameter_numbers => [\@own_idxs],
5104                                      new_values        => [\@from_vals] );
5105           }
5106         }
5107       }
5108 end update_inits
5109
5110 # }}} update_inits
5111
5112 # {{{ upper_bounds
5113
5114 start upper_bounds
5115       {
5116         # upper_bounds either sets or gets the initial values of the
5117         # parameter specified in I<parameter_type> for each
5118         # subproblem specified in I<problem_numbers>. For each
5119         # element in I<problem_numbers> there must be an array in
5120         # I<parameter_numbers> that specify the indices of the
5121         # parameters in the subproblem for which the upper bounds
5122         # are set, replaced or retrieved.
5123
5124         @upper_bounds = @{ $self -> _init_attr
5125                              ( parameter_type    => $parameter_type,
5126                                parameter_numbers => \@parameter_numbers,
5127                                problem_numbers           => \@problem_numbers,
5128                                new_values        => \@new_values,
5129                                attribute         => 'upbnd')};
5130       }
5131 end upper_bounds
5132
5133 # }}} upper_bounds
5134
5135 # {{{ clean_extra_data_code
5136
5137 start clean_extra_data_code
5138     {
5139
5140       # This method cleans out old code for extra data. It searches
5141       # all subroutine statements in all problems for external
5142       # subroutines named "get_sub" and "reader" which are added by
5143       # "add_extra_data_code".
5144
5145       foreach my $problem( @{$self -> {'problems'}} ){
5146         if ( defined $problem -> subroutines and defined $problem -> subroutines -> [0] -> options) {
5147           foreach my $option ( @{$problem -> subroutines -> [0] -> options} ){
5148             if( lc($option -> name) eq 'other'){
5149               if( lc($option -> value) =~ /get_sub|reader/  ){
5150
5151                 # If we find "get_sub" or "reader" we remove
5152                 # everything between "IMPORTING COVARIATE DATA" and
5153                 # "IMPORTING COVARIATE DATA END" by finding the
5154                 # indexes in the code array and and splicing it out.
5155
5156                 my $code;
5157                 if( $problem -> pks ){
5158                   # If the code is in a pk block:
5159                   $code = $problem -> pks -> [0] -> code;
5160                 } else {
5161                   $code = $problem -> preds -> [0] -> code;
5162                 }
5163
5164                 my $start_idx;
5165                 my $end_idx;
5166                 for( my $i = 0; $i <= $#{$code}; $i++ ){
5167                   if( $code -> [$i] eq ";***IMPORTING COVARIATE DATA*******\n" ){
5168                     $start_idx = $i-1;
5169                   }
5170                   if( $code -> [$i] eq ";***IMPORTING COVARIATE DATA END***\n" ){
5171                     $end_idx = $i+1;
5172                   }
5173                 }
5174                 @{$code} = ( @{$code}[0..$start_idx] , @{$code}[$end_idx..$#{$code}] );
5175
5176                 if( $problem -> pks ){
5177                   # Put the cut down code back in the right place:
5178                   $problem -> pks -> [0] -> code( $code );
5179                 } else {
5180                   $problem -> preds -> [0] -> code( $code );
5181                 }
5182
5183                 last;
5184               }
5185             }
5186           }
5187         }
5188       }
5189     }
5190 end clean_extra_data_code
5191
5192 # }}} clean_extra_data_code
5193
5194 # {{{ add_extra_data_code
5195
5196 start add_extra_data_code
5197       {
5198       # This method adds fortran code that will handle wide datasets
5199       # (that is data sets with more than 20 columns). It adds code to
5200       # each problems pk or pred.
5201
5202       my @code_lines;
5203
5204       # Get the headers of the columns that have been moved to another
5205       # data file.
5206
5207 #      unless( defined $self -> extra_data_headers ){
5208 #       die "ERROR model::add_extra_data_code: No headers for the extra data file\n";
5209 #      }
5210
5211       # extra_data_headers is a two dimensional array. One array of
5212       # headers for each problem in the modelfile.
5213       for( my $i = 0; $i <= $#{$self -> {'problems'}}; $i++ ){
5214         if ( defined $self -> {'problems'} -> [$i] -> {'extra_data_header'} ) {
5215           my $problem_headers = $self -> {'problems'} -> [$i] -> {'extra_data_header'};
5216
5217           my $length = 0;
5218           my @headers;
5219           my $header_string;
5220           # Loop over the problem specific headers and make a string
5221           # that will go into the fortran code. Assume that the
5222           # first column holds the ID, hence the $i=1
5223           for (my $i = 1; $i <= $#{$problem_headers}; $i++ ) {
5224             my $header = $problem_headers -> [$i];
5225             push( @headers, $header );
5226             # Chopp the string at 40 characters, to be nice to g77 :)
5227             if ( $length + length($header) > 40 ) {
5228               $header_string .= "\n\"&  ";
5229               $length = 0
5230             }
5231             if ( $i < $#{$problem_headers} ) {
5232               $header_string .= 'I' . $header . ', ';
5233               $length += length( 'I' . $header . ', ' );
5234             } else {
5235               $header_string .= 'I' . $header;
5236               $length += length( 'I' . $header );
5237             }
5238           }
5239
5240           my @code_lines = ('',
5241                             ';***IMPORTING COVARIATE DATA*******',
5242                             '"  FIRST',
5243                             '"  REAL CURID, MID,',
5244                             '"&  '.$header_string,
5245                             '"  LOGICAL READ',
5246                             '"',
5247                             '"  IF (.NOT.READ) THEN',
5248                             '"    CALL READER()',
5249                             '"    CURID = 1',
5250                             '"    READ = .TRUE.',
5251                             '"    END IF',
5252                             '"',
5253                             '"  IF (NEWIND.LT.2) THEN',
5254                             '"    CALL GET_SUB (NEWIND,ID,CURID,MID,',
5255                             '"&  '.$header_string. ')',
5256                             '"  END IF',
5257                             '  CID = MID',
5258                             '  IF (CID.NE.ID) THEN',
5259                             '    PRINT *, \'ERROR CHECKING FAILED, CID = \', CID ,\' ID = \', ID',
5260                             '  END IF',
5261                             '');
5262
5263           foreach my $header ( @headers ) {
5264             push( @code_lines, "  $header = I$header" );
5265           }
5266
5267           push( @code_lines, (';***IMPORTING COVARIATE DATA END***','','') );
5268
5269           my $problem = $self -> {'problems'} -> [$i];
5270           if ( defined $problem -> {'subroutines'} ) {
5271             $problem -> subroutines -> [0] -> _add_option( option_string => 'OTHER=get_sub'.$i.'.f' );
5272             $problem -> subroutines -> [0] -> _add_option( option_string => 'OTHER=reader'.$i.'.f');
5273           } else {
5274             $problem -> add_records( type => 'subroutine', record_strings => ['OTHER=get_sub'.$i.'.f', 'OTHER=reader'.$i.'.f'] );
5275           }
5276
5277           if ( defined $problem -> pks ) {
5278             unshift( @{$problem -> pks -> [0] -> code}, join("\n", @code_lines ));
5279           } else {
5280             unshift( @{$problem -> preds -> [0] -> code},join("\n", @code_lines ));
5281           }
5282         }
5283       }
5284     }
5285 end add_extra_data_code
5286
5287 # }}}
5288
5289 # {{{ drop_dropped
5290
5291 start drop_dropped
5292       {
5293         for( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
5294           $self -> {'datas'}[$i] -> drop_dropped( model_header => $self -> {'problems'}[$i] -> header );
5295           $self -> {'problems'}[$i] -> drop_dropped( );
5296           #$self -> {'datas'}[$i] -> model_header( $self -> {'problems'}[$i] -> header );
5297         }
5298       }
5299 end drop_dropped
5300
5301 # }}} drop_dropped
5302
5303 # {{{ wrap_data
5304
5305 start wrap_data
5306       {
5307         my $default_wrap = 18;
5308
5309         $self -> drop_dropped(1);
5310
5311         my ( @wrap_columns, @cont_columns );
5312         if ( not defined $wrap_column ) {
5313           for( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
5314             my $columns = scalar @{$self -> {'problems'}[$i] -> dropped_columns}-1; #skip ID
5315             my $modulus = $columns%($default_wrap-2); # default_wrap-2 to account for ID and CONT
5316             my $rows = (($columns-$modulus)/($default_wrap-2))+1;
5317             if ( $rows == 1 ) {
5318               push( @wrap_columns, undef );
5319             } else {
5320               push( @wrap_columns, (ceil( $columns/$rows )+2) ); #Must use #cols + ID and CONT
5321             }
5322           }
5323         } else {
5324           for( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
5325             push( @wrap_columns, $wrap_column );
5326           }
5327         }
5328
5329         for( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
5330           next if ( not defined $wrap_columns[$i] );
5331           $wrap_column = $wrap_columns[$i];
5332           $cont_column = $wrap_columns[$i] if( not defined $cont_column );
5333           my ( $prim, $sec ) =
5334             $self -> {'datas'}[$i] -> wrap( cont_column  => $cont_column,
5335                                             wrap_column  => $wrap_column,
5336                                             model_header => $self -> {'problems'}[$i] -> header );
5337           $self -> {'problems'}[$i] -> primary_columns( $prim );
5338           $self -> {'problems'}[$i] -> secondary_columns( $sec );
5339           $self -> {'data_wrapped'}++;
5340         }
5341       }
5342 end wrap_data
5343
5344 # }}} wrap_data
5345
5346 # {{{ unwrap_data
5347 start unwrap_data
5348       {
5349         for( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
5350           $self -> {'datas'}[$i] -> unwrap;
5351           $self -> {'problems'}[$i] -> primary_columns( [] );
5352           $self -> {'problems'}[$i] -> secondary_columns( [] );
5353         }
5354         $self -> {'data_wrapped'} = 0;
5355       }
5356 end unwrap_data
5357 # }}} unwrap_data
5358
5359 # {{{ write_get_subs
5360
5361 start write_get_subs
5362     {
5363       for( my $i = 0; $i <= $#{$self -> {'problems'}}; $i++ ){
5364         if ( defined $self -> {'problems'} -> [$i] -> {'extra_data_header'} and
5365              defined $self -> problems -> [$i] -> extra_data ) {
5366           my @problem_header = @{$self -> {'problems'} -> [$i] -> {'extra_data_header'}};
5367           my @headers;
5368           my $length = 0;
5369           my $header_string;
5370
5371           my $rows = $self -> problems -> [$i] -> extra_data -> count_ind;
5372
5373           # Assume that first column holds the ID. Get rid of it.
5374           shift( @problem_header );
5375           for ( my $i = 0; $i <= $#problem_header; $i++ ) {
5376             my $header = $problem_header[$i];
5377             push( @headers, $header );
5378             # Chop the string at 40 characters, to be nice to g77 :)
5379             if ( $length + length($header) > 40 ) {
5380               $header_string .= "\n     &  ";
5381               $length = 0
5382             }
5383             if ( $i < $#problem_header ) {
5384               $header_string .= $header . ', ';
5385               $length += length( $header . ', ' );
5386             } else {
5387               $header_string .= $header;
5388               $length += length( $header );
5389             }
5390           }
5391
5392           open( FILE, '>', 'get_sub' . $i . '.f' );
5393           print FILE ("      SUBROUTINE GET_SUB (NEWIND,ID,CURID,MID,\n",
5394                       "     &  $header_string)\n",
5395                       "      COMMON /READ/ TID,TCOV\n",
5396                       "\n",
5397                       "      REAL ID,CURID,MID,\n",
5398                       "     &  $header_string\n",
5399                       "\n",
5400                       "      INTEGER NEWIND\n",
5401                       "\n",
5402                       "      REAL TID($rows), TCOV($rows,",scalar @problem_header,")\n",
5403                       "      CURID = 1\n",
5404                       "\n",
5405                       "C     START AT TOP EVERY TIME\n",
5406                       "      IF (NEWIND.EQ.1) THEN \n",
5407                       "12      CONTINUE\n",
5408                       "        IF (CURID.GT.$rows) THEN \n",
5409                       "          PRINT *, \"Covariate data not found for\", ID\n",
5410                       "          MID = -9999\n",
5411                       "          RETURN\n",
5412                       "        END IF\n",
5413                       "\n",
5414                       "        IF (ID.GT.TID (CURID)) THEN\n",
5415                       "          CURID = CURID + 1\n",
5416                       "          GOTO 12\n",
5417                       "        END IF\n",
5418                       "      ELSEIF (NEWIND.EQ.0) THEN\n",
5419                       "        CURID = 1\n",
5420                       "      END IF\n",
5421                       "\n" );
5422           my $length = 0;
5423           for ( my $i = 1; $i <= $#headers+1; $i++ ) {
5424             $length += length("TCOV(I,$i),");
5425             if ( $length > 40 ) {
5426               print FILE "\n";
5427               $length = 0;
5428             }
5429             print FILE "      ".$headers[$i-1] . "  = TCOV(CURID,$i)\n";
5430           }
5431
5432           print FILE ("      MID  = TID(CURID)\n",
5433                       "      END\n",
5434                       "\n" );
5435
5436           close FILE;
5437         }
5438       }
5439       close( FILE );
5440     }
5441 end write_get_subs
5442
5443 # }}}
5444
5445 # {{{ write_readers
5446
5447 start write_readers
5448     {
5449       for( my $i = 0; $i <= $#{$self -> {'problems'}}; $i++ ){
5450         if ( defined $self -> {'problems'} -> [$i] -> {'extra_data_header'} and
5451              defined $self -> {'problems'} -> [$i] -> {'extra_data'} ) {
5452           my @problem_header = @{$self -> {'problems'} -> [$i] -> {'extra_data_header'}};
5453           my @headers;
5454           my $length = 0;
5455
5456           my $rows = $self -> problems -> [$i] -> extra_data -> count_ind;
5457           my $filename = $self -> problems -> [$i] -> extra_data -> filename;
5458           # Assume that first column holds the ID. Get rid of it.
5459           shift( @problem_header );
5460
5461           'debug' -> warn( level   => 2,
5462                            message => "Writing reader".$i.".f to directory".cwd );
5463           open( FILE, '>', 'reader' . $i . '.f' );
5464           print FILE ("      SUBROUTINE READER()\n",
5465                       "\n",
5466                       "      COMMON /READ/ TID,TCOV\n",
5467                       "\n",
5468                       "      REAL TID ($rows), TCOV ($rows, ",scalar @problem_header,")\n",
5469                       "\n",
5470                       "      OPEN (UNIT = 77,FILE = '$filename')\n",
5471                       "      REWIND 77\n",
5472                       "      DO 11,I = 1,$rows\n",
5473                       "        READ (77,*) TID(I)," );
5474
5475           my $length = 0;
5476           for ( my $i = 1; $i <= $#problem_header+1; $i++ ) {
5477             $length += length("TCOV(I,$i),");
5478             if ( $length > 40 ) {
5479               print FILE "\n     &  ";
5480               $length = 0;
5481             }
5482             if ( $i <= $#problem_header ) {
5483               print FILE "TCOV(I,$i),";
5484             } else {
5485               print FILE "TCOV(I,$i)\n";
5486             }
5487           }
5488
5489           print FILE ( "11      CONTINUE\n",
5490                        "      END\n" );
5491         }
5492       }
5493     }
5494 end write_readers
5495
5496 # }}}
5497
5498 # {{{ _write
5499
5500 start _write
5501       {
5502         #
5503         # $model -> _write( filename => 'model.mod' );
5504         #
5505         # Writes the content of the modelobject to disk. Either to the
5506         # filename given, or to the string returned by model::full_name.
5507
5508         my @formatted;
5509
5510         # An element in the active_problems array is a boolean that
5511         # corresponds to the element with the same index in the problems
5512         # array.  If the boolean is true, the problem will be run. All
5513         # other will be commented out.
5514         my @active = @{$self -> {'active_problems'}};
5515
5516         # loop over all problems.
5517         for ( my $i = 0; $i < scalar @{$self -> {'problems'}}; $i++ ) {
5518           # Call on the problem object to format it as text. The
5519           # filename and problem numbers are needed to make some
5520           # autogenerated files (msfi, tabels etc...) unique to the
5521           # model and problem
5522           my @preformatted = @{$self -> {'problems'} -> [$i] ->
5523                                    _format_problem( filename => $self -> filename,
5524                                                     problem_number => ($i+1) ) };
5525           # Check if the problem is NOT active, if so comment it out.
5526           unless ( $active[$i] ) {
5527             for ( my $j = 0; $j <= $#preformatted; $j++ ) {
5528               $preformatted[$j] = '; '.$preformatted[$j];
5529             }
5530           }
5531           # Add extra line to avoid problems with execution of NONMEM
5532           push(@preformatted,"\n");
5533           push( @formatted, @preformatted );
5534         }
5535
5536         # Open a file and print the formatted problems.
5537         # TODO Add some errorchecking.
5538         open( FILE, '>'. $filename );
5539         for ( @formatted ) {
5540           chomp;
5541           print FILE;
5542           print FILE "\n";
5543         }
5544         close( FILE );
5545
5546         if ( $write_data ) {
5547           foreach my $data ( @{$self -> {'datas'}} ) {
5548             $data -> _write;
5549           }
5550         }
5551
5552         if( $self -> {'iofv_modules'} ){
5553           $self -> {'iofv_modules'} -> [0] -> post_process;
5554         }
5555
5556       }
5557 end _write
5558
5559 # }}} _write
5560
5561 # {{{ filename
5562 start filename
5563       {
5564         if ( defined $parm and $parm ne $self -> {'filename'} ) {
5565           $self -> {'filename'} = $parm;
5566           $self -> {'model_id'} = undef;
5567 #         $self -> _write;
5568         }
5569       }
5570 end filename
5571 # }}} filename
5572
5573 # {{{ _get_option_val_pos
5574
5575 start _get_option_val_pos
5576       {
5577         # Usage:
5578         #
5579         #   ( $values_ref, $positions_ref ) ->
5580         #               _get_option_val_pos ( name        => 'ID',
5581         #                                     record_name => 'input' );
5582         #   my @values = @{$values_ref};
5583         #   my @positions = @{$positions_ref};
5584         #
5585         # This basic usage returns the name of the third option in the first
5586         # instance of the record specified by I<record_name> for all problems
5587         #
5588         # If global_position is set to 1, only one value and position
5589         # pair is returned per problem. If there are more than one
5590         # match in the model; the first will be returned for each
5591         # problem.
5592         #
5593         # Private method, should preferably not be used outside model.pm
5594
5595 #       my ( @records, @instances );
5596         my $accessor = $record_name.'s';
5597         my @problems = @{$self -> {'problems'}};
5598         unless( $#problem_numbers > 0 ){
5599           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
5600         }
5601         foreach my $i ( @problem_numbers ) {
5602           my $rec_ref = $problems[ $i-1 ] -> $accessor;
5603           if ( defined $problems[ $i-1 ] and defined $rec_ref ) {
5604             my @records = @{$rec_ref};
5605             unless( $#instances > 0 ){
5606               @instances = (1 .. $#records+1);
5607
5608             }
5609             my @inst_values    = ();
5610             my @inst_positions = ();
5611             my $glob_pos = 1;
5612             my ( $glob_value, $glob_position );
5613 INSTANCES:  foreach my $j ( @instances ) {
5614               if ( defined $records[ $j-1 ] ) {
5615                 my $k = 1;
5616                 my ( $value, $position );
5617                 foreach my $option ( @{$records[$j-1] -> {'options'}} ) {
5618                   if ( defined $option and $option -> name eq $name) {
5619                     if ( $global_position ) {
5620                       $glob_value = $option -> value;
5621                       $glob_position = $glob_pos;
5622                       last INSTANCES;
5623                     } else {
5624                       $value = $option -> value;
5625                       $position = $k;
5626                     }
5627                   }
5628                   $k++;
5629                   $glob_pos++;
5630                 }
5631                 push( @inst_values, $value );
5632                 push( @inst_positions, $position );
5633               } else {
5634                 'debug' -> die( message => "Instance $j in problem number $i does not exist!" )
5635               }
5636             }
5637             if ( $global_position ) {
5638               push( @values, $glob_value );
5639               push( @positions, $glob_position );
5640             } else {
5641               push( @values, \@inst_values );
5642               push( @positions, \@inst_positions );
5643             }
5644           } else {
5645             'debug' -> die( message => "Problem number $i does not exist!" );
5646           }
5647         }
5648 #       if( defined $problem_number ) {
5649 #         if( $problem_number < 1 or $problem_number > scalar @problems ) {
5650 #           die "model -> _get_option_val_pos: No such problem number, ",
5651 #             $problem_number,", in this model!\n";
5652 #         }
5653 #       }
5654 #       my $i;
5655 #       die "modelfile -> _get_option_val_pos: No problem $problem_number exists\n"
5656 #         if( (scalar @problems < 1) and ($problem_number ne 'all') );
5657 #       my $j = 1;
5658 #       foreach my $problem ( @problems ) {
5659 #         @records = @{$problem -> $accessor};
5660 #         @records = ($records[$instance-1]) if ( $instance ne 'all' );
5661 #         die "modelfile -> _get_option_val_pos: No record instance $instance ".
5662 #           "of record $record_name in problem $problem_number exists\n"
5663 #             if( (scalar @records < 1) and ($instance ne 'all') );
5664 #         foreach my $record ( @records ) {
5665 #           $i = 1;
5666 #           foreach my $option ( @{$record -> {'options'}} ) {
5667 #             if ( defined $option and $option -> name eq $name) {
5668 #               print "Found $name at $i\n" if ( $self -> {'debug'} );
5669 #               push( @values, $option -> value );
5670 #               push( @positions, $i );
5671 #             }
5672 #             $i++;
5673 #           }
5674 #         }
5675 #       }
5676       }
5677 end _get_option_val_pos
5678
5679 # }}} _get_option_val_pos
5680
5681 # {{{ _init_attr
5682
5683 start _init_attr
5684       {
5685         # The I<add_if_absent> argument tells the method to add an init (theta,omega,sigma)
5686         # if the parameter number points to a non-existing parameter with parameter number
5687         # one higher than the highest presently included. Only applicatble if
5688         # I<new_values> are set. Default value = 0;
5689
5690         unless( scalar @problem_numbers > 0 ){
5691           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
5692         }
5693         my @problems = @{$self -> {'problems'}};
5694         if ( $#new_values >= 0 ) {
5695           'debug' -> die( message => "The number of new value sets " .
5696                           ($#new_values+1) . " do not" .
5697                           " match the number of problems " . ($#problem_numbers+1) . " specified" )
5698               unless(($#new_values == $#problem_numbers) );
5699           if ( $#parameter_numbers > 0 ) {
5700             'debug' -> die( message => "The number of parameter number sets do not" .
5701                             " match the number of problems specified" )
5702                 unless(($#parameter_numbers == $#problem_numbers) );
5703           }
5704         }
5705
5706         my $new_val_idx = 0;
5707         foreach my $i ( @problem_numbers ) {
5708           if ( defined $problems[ $i-1 ] ) {
5709             if ( scalar @new_values > 0) {
5710               # {{{ Update values
5711               # Use attribute parameter_values to collect diagnostic outputs
5712               push( @parameter_values,
5713                     $problems[ $i-1 ] ->
5714                     _init_attr( parameter_type    => $parameter_type,
5715                                 parameter_numbers => $parameter_numbers[ $new_val_idx ],
5716                                 new_values        => \@{$new_values[ $new_val_idx ]},
5717                                 attribute         => $attribute,
5718                                 add_if_absent     => $add_if_absent ) );
5719               # }}} Update values
5720             } else {
5721               # {{{ Retrieve values
5722               push( @parameter_values,
5723                     $problems[ $i-1 ] ->
5724                     _init_attr( parameter_type    => $parameter_type,
5725                                 parameter_numbers => $parameter_numbers[ $i-1 ],
5726                                 attribute         => $attribute ) );
5727               # }}} Retrieve values
5728             }
5729           } else {
5730             'debug' -> die( message => "Problem number $i does not exist!" );
5731           }
5732           $new_val_idx++;
5733         }
5734       }
5735 end _init_attr
5736
5737 # }}} _init_attr
5738
5739 # {{{ _option_name
5740
5741 start _option_name
5742       {
5743         # Usage:
5744         #
5745         #   $modobj -> _option_name ( record   => $record_name,
5746         #                             position => 3 );
5747         #
5748         # This basic usage returns the name of the third option in the first
5749         # instance of the record specified by I<record>.
5750         #
5751
5752         my ( @problems, @records, @options, $i );
5753         my $accessor = $record.'s';
5754         if ( defined $self -> {'problems'} ) {
5755           @problems = @{$self -> {'problems'}};
5756         } else {
5757           'debug' -> die( message => "No problems defined in model" );
5758         }
5759         if ( defined $problems[$problem_number - 1] -> $accessor ) {
5760           @records = @{$problems[$problem_number - 1] -> $accessor};
5761         } else {
5762           'debug' -> die( message => "No record $record defined in ".
5763                           "problem number $problem_number." );
5764         }
5765         if ( defined $records[$instance - 1] -> options ) {
5766           @options = @{$records[$instance - 1] -> options};
5767         } else {
5768           'debug' -> die( message => "model -> _option_name: No option defined in record ".
5769                           "$record in problem number $problem_number." );
5770         }
5771         $i = 0;
5772         foreach my $option ( @options ) {
5773           if ( $i == $position ) {
5774             if ( defined $new_name ){
5775               $option -> name($new_name) if ( defined $option );
5776             }else{
5777               $name = $option -> name if ( defined $option );
5778             }
5779           }
5780           $i++;
5781         }
5782       }
5783 end _option_name
5784
5785 # }}} _option_name
5786
5787 # {{{ _parameter_count
5788 start _parameter_count
5789       {
5790         if( defined $self -> {'problems'} ){
5791           my $problems = $self -> {'problems'};
5792           if( defined @{$problems}[$problem_number - 1] ){
5793             $count = @{$problems}[$problem_number - 1] -> record_count( 'record_name' => $record );
5794           }
5795         }
5796       }
5797 end _parameter_count
5798 # }}} _parameter_count
5799
5800 # {{{ _read_problems
5801
5802 start _read_problems
5803     {
5804
5805       # To read problems from a modelfile we need its full name
5806       # (meaning filename and path). And we need an array for the
5807       # modelfile lines and an array with indexes telling where
5808       # problems start in the modelfile array.
5809
5810
5811       my $file = $self -> full_name;
5812       my ( @modelfile, @problems );
5813       my ( @problem_start_index );
5814
5815       # Check if the file is missing, and if that is ok.
5816       # TODO Check accessor what happens if the file is missing.
5817
5818       return if( not (-e $file) && $self -> {'ignore_missing_files'} );
5819
5820       # Open the file, slurp it and close it
5821       open( FILE, "$file" ) ||
5822           'debug' -> die( message => "Model -> _read_problems: Could not open $file".
5823                         " for reading" );
5824       @modelfile = <FILE>;
5825       close( FILE );
5826
5827       my @extra_data_files   = defined $self ->{'extra_data_files'} ?
5828           @{$self -> {'extra_data_files'}} : ();
5829       my @extra_data_headers = defined $self ->{'extra_data_headers'} ?
5830           @{$self -> {'extra_data_headers'}} : ();
5831
5832
5833 #       # Find the indexes where the problems start
5834 #       for ( my $i = 0; $i <= $#modelfile; $i++ ) {
5835 #       push( @problem_start_index, $i )if ( $modelfile[$i] =~ /\$PROB/ );
5836 #       }
5837
5838 #       # Loop over the number of problems. Copy the each problems lines
5839 #       # and create a problem object.
5840
5841 #       for( my $i = 0; $i <= $#problem_start_index; $i++ ) {
5842 #       my $start_index = $problem_start_index[$i];
5843 #       my $end_index = defined $problem_start_index[$i+1] ? $problem_start_index[$i+1] - 1: $#modelfile ;
5844 #       # Line copy
5845 #       my @problem_lines = @modelfile[$start_index .. $end_index];
5846
5847 #       # Problem object creation.
5848 #       push( @problems, model::problem -> new ( debug                => $self -> {'debug'},
5849 #                                                ignore_missing_files => $self -> {'ignore_missing_files'},
5850 #                                                prob_arr             => \@problem_lines,
5851 #                                                extra_data_file_name => $extra_data_files[$i],
5852 #                                                extra_data_header    => $extra_data_headers[$i]) );
5853
5854       my $start_index = 0;
5855       my $end_index;
5856       my $first = 1;
5857       my $prob_num = 0;
5858
5859       # It may look like the loop takes one step to much, but its a
5860       # trick that helps parsing the last problem.
5861       for ( my $i = 0; $i <= @modelfile; $i++ ) {
5862         if( $i <= $#modelfile ){
5863           $_ = $modelfile[$i];
5864         }
5865
5866         if ($first and not /^\s*(;|\$PROB|$)/){
5867           'debug' -> die( message => 'Model -> _read_problems: '.
5868                           "First non-comment line in modelfile $file \n".
5869                           'is not a $PROB record. NONMEM syntax violation.');
5870         }
5871
5872         # In this if statement we use the lazy evaluation of logical
5873         # or to make sure we only execute search pattern when we have
5874         # a line to search. Which is all cases but the very last loop
5875         # iteration.
5876
5877         if( $i > $#modelfile or /^\s*\$PROB/ ){
5878           $end_index = $i;
5879
5880           # The if statement here is only necessary in the first loop
5881           # iteration. When start_index == end_index == 0 we want to
5882           # skip to the next iteration looking for the actual end of
5883           # the first problem.
5884
5885           if( $end_index > $start_index and not $first ){
5886             # extract lines of code:
5887             my @problem_lines = @modelfile[$start_index .. $end_index-1];
5888             # reset the search for problems by moving the problem start
5889             # forwards:
5890             $start_index = $i;
5891
5892             my $sh_mod = model::shrinkage_module -> new ( model   => $self,
5893                                                           temp_problem_number => ($#problems+2));
5894             my $prob = model::problem ->
5895                 new ( directory                   => $self -> {'directory'},
5896                       ignore_missing_files        => $self -> {'ignore_missing_files'},
5897                       ignore_missing_output_files => $self -> {'ignore_missing_output_files'},
5898                       sde                         => $self -> {'sde'},
5899                       cwres                       => $self -> {'cwres'},
5900                       mirror_plots                => $self -> {'mirror_plots'},
5901                       nm_version                  => $self -> {'nm_version'},
5902                       prob_arr                    => \@problem_lines,
5903                       extra_data_file_name        => $extra_data_files[$prob_num],
5904                       extra_data_header           => $extra_data_headers[$prob_num],
5905                       shrinkage_module            => $sh_mod );
5906             push( @problems, $prob );
5907             if ( $self -> cwres() ) {
5908               my @eo;
5909               if ( defined $self -> extra_output() ) {
5910                 @eo = @{$self -> extra_output()};
5911               }
5912               if( $prob -> {'cwres_modules'} ){
5913                 push( @eo, @{$prob -> {'cwres_modules'} -> [0] -> cwtab_names()} );
5914               }
5915               $self -> extra_output( \@eo );
5916             }
5917
5918             $sh_mod -> problem( $problems[$#problems] );
5919             $prob_num++;
5920           }
5921           $first = 0;
5922         }
5923       }
5924
5925       # Set the problems in the modelobject.
5926       if (scalar(@problems)<1){
5927           'debug' -> die( message => 'Model -> _read_problems: '.
5928                           "Could not find any problem in modelfile $file");
5929       }
5930       $self -> problems(\@problems);
5931     }
5932 end _read_problems
5933
5934 # }}} _read_problems
5935
5936 # {{{ set_option
5937
5938 start set_option
5939
5940 unless( $#problem_numbers >= 0 ){
5941   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
5942 }
5943
5944 my @problems = @{$self -> {'problems'}};
5945 foreach my $i ( @problem_numbers ) {
5946   if ( defined $problems[ $i-1 ] ) {
5947     my $found = $self -> is_option_set( 'problem_number' => $i,
5948                                         'record'         => $record_name,
5949                                         'name'           => $option_name,
5950                                         'fuzzy_match'    => $fuzzy_match );
5951     $problems[$i-1] -> remove_option( record_name  => $record_name,
5952                                       option_name  => $option_name,
5953                                       fuzzy_match  => $fuzzy_match ) if ( $found );
5954     $problems[$i-1] -> add_option( record_name  => $record_name,
5955                                    option_name  => $option_name,
5956                                    option_value => $option_value );
5957   }
5958 }
5959
5960 end set_option
5961
5962 # }}} set_option
5963
5964 # {{{ add_option
5965
5966 start add_option
5967
5968 unless( $#problem_numbers >= 0 ){
5969   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
5970 }
5971
5972 my @problems = @{$self -> {'problems'}};
5973 foreach my $i ( @problem_numbers ) {
5974   if ( defined $problems[ $i-1 ] ) {
5975     $problems[$i-1] -> add_option( record_name  => $record_name,
5976                                    option_name  => $option_name,
5977                                    option_value => $option_value,
5978                                    add_record   => $add_record );
5979   }
5980 }
5981
5982 end add_option
5983
5984 # }}} add_option
5985
5986 # {{{ remove_option
5987
5988 start remove_option
5989
5990 unless( $#problem_numbers >= 0 ){
5991   @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
5992 }
5993
5994 my @problems = @{$self -> {'problems'}};
5995 foreach my $i ( @problem_numbers ) {
5996   if ( defined $problems[ $i-1 ] ) {
5997     $problems[$i-1] -> remove_option( record_name => $record_name,
5998                                       option_name => $option_name,
5999                                       fuzzy_match => $fuzzy_match);
6000   }
6001 }
6002
6003 end remove_option
6004
6005 # }}} remove_option
6006
6007 # {{{ _option_val_pos
6008
6009 start _option_val_pos
6010       {
6011         unless( $#problem_numbers >= 0 ){
6012           @problem_numbers = (1 .. $#{$self -> {'problems'}}+1);
6013         }
6014         my @problems = @{$self -> {'problems'}};
6015         if ( $#new_values >= 0 ) {
6016           'debug' -> die( message => "Trying to set option $name in record $record_name but the ".
6017                           "number of new value sets (".
6018                           ($#new_values+1).
6019                           "), do not match the number of problems specified (".
6020                           ($#problem_numbers+1).")" )
6021               unless(($#new_values == $#problem_numbers) );
6022           if ( $#instance_numbers > 0 ) {
6023               'debug' -> die( message => "The number of instance number sets (".
6024                               ($#instance_numbers+1).
6025                               "),do not match the number of problems specified (".
6026                               ($#problem_numbers+1).")" )
6027                 unless(($#instance_numbers == $#problem_numbers) );
6028           }
6029         }
6030
6031         foreach my $i ( @problem_numbers ) {
6032           if ( defined $problems[ $i-1 ] ) {
6033             my $rn_ref = $#instance_numbers >= 0 ? \@{$instance_numbers[ $i-1 ]} : [];
6034             if ( scalar @new_values > 0) {
6035               # {{{ Update values
6036
6037               if( not defined $new_values[ $i-1 ] ) {
6038                 debug -> die( message => " The specified new_values was undefined for problem $i" );
6039               }
6040
6041               if( not ref( $new_values[ $i-1 ] ) eq 'ARRAY' ) {
6042                 debug -> die( message => " The specified new_values for problem $i is not an array as it should be but a ".
6043                               ( defined ref( $new_values[ $i-1 ] ) ?
6044                                 ref( $new_values[ $i-1 ] ) : 'undef' ) );
6045               }
6046
6047               $problems[ $i-1 ] ->
6048                 _option_val_pos( record_name      => $record_name,
6049                                  instance_numbers => $rn_ref,
6050                                  new_values       => \@{$new_values[ $i-1 ]},
6051                                  name             => $name,
6052                                  exact_match      => $exact_match );
6053
6054               # }}} Update values
6055             } else {
6056               # {{{ Retrieve values
6057               my ( $val_ref, $pos_ref ) =
6058                 $problems[ $i-1 ] ->
6059                   _option_val_pos( record_name      => $record_name,
6060                                    instance_numbers => $rn_ref,
6061                                    name             => $name,
6062                                    exact_match      => $exact_match );
6063               push( @values, $val_ref );
6064               push( @positions, $pos_ref );
6065               # }}} Retrieve values
6066             }
6067           } else {
6068             'debug' -> die( message => "Problem number $i does not exist!" );
6069           }
6070         }
6071       }
6072 end _option_val_pos
6073
6074 # }}} _option_val_pos
6075
6076 # {{{ subroutine_files
6077
6078 start subroutine_files
6079 {
6080   my %fsubs;
6081   foreach my $subr( 'PRED','CRIT', 'CONTR', 'CCONTR', 'MIX', 'CONPAR', 'OTHER', 'PRIOR' ){
6082     my ( $model_fsubs, $junk ) = $self -> _option_val_pos( record_name => 'subroutine',
6083                                                            name => $subr );
6084     if( @{$model_fsubs} > 0 ){
6085       foreach my $prob_fsubs ( @{$model_fsubs} ){
6086         foreach my $fsub( @{$prob_fsubs} ){
6087           $fsubs{$fsub} = 1;
6088         }
6089       }
6090     }
6091   }
6092
6093   # BUG , nonmem6 might not require the file to be named .f And I've
6094   # seen examples of files named .txt
6095
6096   @fsubs = keys %fsubs;
6097   if( @fsubs > 0  ){
6098     for( my $i = 0; $i <= $#fsubs; $i ++ ){
6099       unless( $fsubs[$i] =~ /\.f$/ ){
6100         $fsubs[$i] .= '.f';
6101       }
6102     }
6103   }
6104 }
6105 end subroutine_files
6106
6107 # }}}
6108
6109 # {{{ get_option_value
6110 start get_option_value
6111     {
6112         #$modelObject -> get_option_value(record_name => 'recordName', option_name => 'optionName',
6113         #                         problem_index => <index>, record_index => <index>/'all',
6114         #                         option_index => <index>/'all')
6115         # record_name and option_name are required. All other have default 0.
6116         #record_index and option_index may either be scalar integer or string 'all'.
6117         # Depending on input parameters the return value can be
6118         # Case 1. a scalar for record_index => integer, option_index => integer
6119         # Case 2. a reference to an array of scalars for (record_index=>'all',option_index => integer)
6120         # Case 3. a reference to an array of scalars for (record_index=>integer,option_index => 'all')
6121         # Case 4. a reference to an array of references to arrays for (record_index=>'all',option_index => 'all')
6122         my ( @problems, @records, @options );
6123         my $accessor = $record_name.'s';
6124         my @rec_arr;
6125         my $fail;
6126
6127 #       print "start get option\n";
6128
6129         #Basic error checking. Error return type is undef for Case 1
6130         #and reference to empty array for Case 2 and 3 and 4.
6131
6132         if (lc($record_index) eq 'all' || lc($option_index) eq 'all' ){
6133             $fail = [];
6134         } else {
6135             $fail =  undef;
6136         }
6137
6138         if ( defined $self -> {'problems'} ) {
6139             @problems = @{$self -> {'problems'}};
6140         } else {
6141             'debug' -> warn( level => 2,message => "No problems defined in model" );
6142             return $fail;
6143         }
6144         unless( defined $problems[$problem_index] ){
6145             'debug' -> warn( level => 2,
6146                              message => "model -> get_option_value: No problem with ".
6147                              "index $problem_index defined in model" );
6148             return $fail;
6149         }
6150
6151         if ( defined $problems[$problem_index] -> $accessor ) {
6152             @records = @{$problems[$problem_index] -> $accessor};
6153         } else {
6154             'debug' -> warn( level => 2,
6155                              message => "model -> get_option_value: No record $record_name defined" .
6156                              " in problem with index $problem_index." );
6157             return $fail;
6158         }
6159
6160         #go through all records, whole array is of correct type.
6161         #if current record is the single we want, investigare option values and break out of loop
6162         #if we want to look at all records, investigare option values and continue with loop
6163       REC: for (my $ri=0; $ri<scalar(@records); $ri++){
6164           if ((lc($record_index) eq 'all') || $record_index==$ri){
6165               my @val_arr = ();
6166               unless ((defined $records[$ri]) &&( defined $records[$ri] -> options )){
6167                   'debug' -> warn( level => 2,
6168                                    message => "model -> get_option_value: No options for record index ".
6169                                    "$record_index defined in problem." );
6170                   if (lc($record_index) eq 'all'){
6171                       if (lc($option_index) eq 'all'){
6172                           push(@rec_arr,[]); #Case 4
6173                       } else {
6174                           push(@rec_arr,undef); #Case 2
6175                       }
6176                       next REC;
6177                   } else {
6178                       if (lc($option_index) eq 'all'){
6179                           $return_value = []; #Case 3
6180                       } else {
6181                           $return_value = undef; #Case 1
6182                       }
6183                       last REC; #we are done
6184                   }
6185               }
6186               @options = @{$records[$ri] -> options};
6187               my $oi=-1;
6188               my $val;
6189               #go through all options (array contains all options, regardless of name).
6190               # For each check if it the correct type, if so
6191               #increase counter $oi after possibly storing the option value
6192               #if current correct option is the single we want value for, then
6193               #store value and break out of loop. If want to store values for
6194               #all correct options, store value and then continue with loop
6195               foreach my $option ( @options ) {
6196                   if (defined $option and
6197                       (($option->name eq $option_name) || (index($option_name,$option ->name ) > -1))){
6198                       $oi++; #first is 0
6199                       if (lc($option_index) eq 'all' || $option_index == $oi){
6200                           if ( (defined $option -> {'value'}) and ($option -> {'value'} ne '')){
6201                               $val = $option -> {'value'};
6202                           } else {
6203                               $val = undef;
6204                           }
6205                           if (lc($option_index) eq 'all'){
6206                               push(@val_arr,$val); #Case 3 and 4
6207                           } else {
6208                               last; #Case 1 and 2.  Take care of $val outside loop over options
6209                           }
6210                       }
6211                   }
6212               }
6213               if (lc($record_index) eq 'all'){
6214                   if (lc($option_index) eq 'all'){
6215                       push(@rec_arr,\@val_arr); #Case 4
6216                   } else {
6217                       push(@rec_arr,$val); #Case 2
6218                   }
6219                   next REC;
6220               } else {
6221                   if (lc($option_index) eq 'all'){
6222                       $return_value = \@val_arr; #Case 3
6223                   } else {
6224                       $return_value = $val; #Case 1
6225                   }
6226                   last REC;
6227               }
6228           }
6229       }
6230         if (lc($record_index) eq 'all'){
6231             $return_value = \@rec_arr; #Case 2 and 4
6232         }
6233
6234     }
6235 end get_option_value
6236
6237 # }}} get_option_value