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