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