lib/model/problem_subs.pm

   1 # {{{ Include
   2
   3 start include statements
   4 use Data::Dumper;
   5 my @print_order = ('problem','abbreviated','input','data','msfi','contr','subroutine','model','infn','omega','pk','aesinit','aes','des','error','pred','mix','theta','sigma','simulation','estimation','covariance','nonparametric','table','scatter');
   6 my @sde_print_order = ('problem','abbreviated','input','data','msfi','contr','subroutine','model','infn','theta','omega','sigma','pk','aesinit','aes','des','error','pred','mix','simulation','estimation','covariance','nonparametric','table','scatter');
   7 my %abbreviations;
   8
   9 # Here we intialize a hash used to find long names for abbreviated
  10 # record names. We use the print_order array which contains all
  11 # allowed record types.
  12
  13 foreach my $record_name( @print_order ){
  14   my $uc_short_type = substr(uc($record_name),0,3);;
  15   $uc_short_type = $uc_short_type.' ' if ( $record_name eq 'aes' );
  16   $uc_short_type = $uc_short_type.'I' if ( $record_name eq 'aesinit' );
  17   $abbreviations{$uc_short_type} = $record_name;
  18 }
  19 end include statements
  20
  21 # }}} include statements
  22
  23 # {{{ new
  24
  25 start new
  26     {
  27
  28       unless ( defined $parm{'problems'} ) {
  29         # Parse given problem lines.
  30         $this -> _read_records();
  31         delete $this -> {'prob_arr'};
  32       }
  33
  34       # Initialize table file objects (if any)
  35       $this -> _read_table_files( ignore_missing_files =>
  36                                   $this -> {'ignore_missing_output_files'} );
  37
  38       # Initialize extra_data objects (if any)
  39       if ( defined $this -> {'extra_data_file_name'} ) {
  40         $this -> {'extra_data'} = extra_data -> new ( filename => $this -> {'extra_data_file_name'},
  41                                                       header   => $this -> {'extra_data_header'},
  42                                                       target   => 'disk',
  43                                                       ignore_missing_files =>
  44                                                       $this -> {'ignore_missing_files'} );
  45       }
  46
  47       if( $this -> {'cwres'} ){
  48
  49         $this -> add_cwres_module( 'init_data' => { problem => $this,
  50                                                     nm_version => $this -> {'nm_version'},
  51                                                     mirror_plots => $this -> {'mirror_plots'} } );
  52
  53       }
  54
  55     }
  56 end new
  57
  58 # }}} new
  59
  60 # {{{ add_marginals_code
  61
  62 start add_marginals_code
  63
  64 # add_marginals_code takes one argument.
  65 #
  66 # - nomegas which is the number of (diagonal-element)
  67 # omegas.
  68 #
  69 # For each omega, verbatim code is added to make the marginals
  70 # available for printing (e.g. to a table file). COM(1) will hold the
  71 # nonparametric density, COM(2) the marginal cumulative value for the
  72 # first eta, COM(2) the marginal cumulative density for the second eta
  73 # and so on.
  74 # The code is added to the $ERROR record
  75
  76 my $record_ref = $self -> errors;
  77 if( defined $record_ref and defined $record_ref -> [0] ) {
  78   my ( @first_params, @last_params );
  79   $last_params[0] = '"   COM(1) = DENM';
  80   $first_params[0] = '"     X ';
  81   my $j = 0;
  82   my $comma;
  83   for( my $i = 1; $i <= $nomegas; $i++ ) {
  84     $comma = $i == $nomegas ? '' : ',';
  85     if( not ($i % 4) ) { # break line every fifth omega
  86       $j++;
  87       $first_params[$j] = '"     X ';
  88     }
  89     $first_params[$j] = $first_params[$j]."DEN$i$comma";
  90     push( @last_params, '"   COM('.($i+1).") = DEN$i" );
  91   }
  92   my $first_code = $record_ref -> [0] -> verbatim_first;
  93   push( @{$first_code}, ( '"  COMMON /ROCM18/ DENM,', @first_params,
  94                           '"  DOUBLE PRECISION DENM,', @first_params ) );
  95   $record_ref -> [0] -> verbatim_first( $first_code );
  96   my $last_code = $record_ref -> [0] -> verbatim_last;
  97   push( @{$last_code}, @last_params );
  98   $record_ref -> [0] -> verbatim_last( $last_code );
  99   last; # Only insert the code in the first record found (of the ones specified above)
 100 } else {
 101   'debug' ->  warn( level => 2,
 102                     message => "No \$ERROR record was found. Can't add verbatim code".
 103                     " to access nonparametric marginals" );
 104 }
 105
 106 end add_marginals_code
 107
 108 # }}} add_marginals_code
 109
 110 # {{{ cont_wrap_columns
 111
 112 start cont_wrap_columns
 113       {
 114         if ( defined $self -> {'primary_columns'} ) {
 115           $wrap_column = scalar @{$self -> {'primary_columns'}};
 116           for ( my $i = 0; $i < $wrap_column ; $i++ ) {
 117             $cont_column = ($i+1) if ( $self -> {'primary_columns'}[$i][0] eq 'CONT' );
 118           }
 119         }
 120       }
 121 end cont_wrap_columns
 122
 123 # }}} cont_wrap_columns
 124
 125 # {{{ contify_tables
 126
 127 start contify_tables
 128
 129 if( defined $self -> {'tables'} ){
 130   for( my $i = 0; $i < scalar @{$self -> {'tables'}}; $i++ ) {
 131     my $table = $self -> {'tables'}[$i];
 132     my $cont_column = $table -> contify;
 133 # I don't know what I had in mind when I wrote this piece of code:
 134 # Maybe I'll remember some day, better leave it as it is for now:
 135
 136 #           my @prim;
 137 #           for( my $j = 1; $j <= scalar @{$table -> options}; $j++ ) {
 138 #             my $option = $options[$j-1];
 139 #             my $name = $option -> name;
 140 #             last if( $name eq 'BY' or  $name eq 'PRINT' or $name eq 'NOPRINT' or
 141 #                      $name eq 'FILE' or $name eq 'NOHEADER' or $name eq 'ONEHEADER' or
 142 #                      $name eq 'FIRSTONLY' or $name eq 'NOFORWARD' or $name eq 'FORWARD' or
 143 #                      $name eq 'APPEND' or $name eq 'NOAPPEND' or $name eq 'UNCONDITIONAL' or
 144 #                      $name eq 'CONDITIONAL' or $name eq 'OMITTED' );
 145 #             my @col = ( $name, $j, $option -> value );
 146 #             push( @prim, \@col );
 147 #           }
 148     if( defined $self -> {'table_files'} and defined $self -> {'table_files'}[$i] ) {
 149 #             $self -> {'table_files'}[$i] -> primary_columns( \@prim );
 150       $self -> {'table_files'}[$i] -> cont_column( $cont_column );
 151     }
 152   }
 153 }
 154
 155 end contify_tables
 156
 157 # }}} contify_tables
 158
 159 # {{{ dropped_columns
 160
 161 start dropped_columns
 162       {
 163         my $inp_ref = $self -> inputs;
 164         if ( defined $inp_ref and defined $inp_ref -> [0] ) {
 165           my $input = $inp_ref -> [0];
 166           my $opt_ref = $input -> options;
 167           if ( defined $opt_ref ) {
 168             my @options = @{$opt_ref};
 169             foreach my $option ( @options ) {
 170               my $dropped = ( $option -> value eq 'DROP' or
 171                               $option -> value eq 'SKIP' ) ? 1 : 0;
 172               push ( @dropped_columns, $dropped );
 173             }
 174           }
 175         }
 176       }
 177 end dropped_columns
 178
 179 # }}} dropped_columns
 180
 181 # {{{ drop_dropped
 182
 183 start drop_dropped
 184       {
 185         my $inp_ref = $self -> inputs;
 186         # Important that the drop_dropped method of the data class is
 187         # in sync with this method.
 188         if ( defined $inp_ref and defined $inp_ref -> [0] ) {
 189           my $input = $inp_ref -> [0];
 190           my $opt_ref = $input -> options;
 191           if ( defined $opt_ref ) {
 192             my @options = @{$opt_ref};
 193             my @keep;
 194             foreach my $option ( @options ) {
 195               push ( @keep, $option ) if ( not ($option -> value eq 'DROP' or $option -> value eq 'SKIP') or
 196                                            $option -> name =~ /DAT(E|1|2|3)/ );
 197             }
 198             $input -> options( \@keep );
 199           }
 200         }
 201       }
 202 end drop_dropped
 203
 204 # }}} drop_dropped
 205
 206 # {{{ extra_data_header
 207 start extra_data_header
 208       {
 209         if ( defined $parm ) {
 210           if ( defined $self -> {'extra_datas'} and
 211                defined $self -> {'extra_datas'} -> [0] ) {
 212             $self -> {'extra_datas'} -> [0] -> header( $parm );
 213           }
 214         }
 215       }
 216 end extra_data_header
 217 # }}}
 218
 219 # {{{ extra_data_file_name
 220
 221 start extra_data_file_name
 222       {
 223         if ( defined $parm ) {
 224           $self -> {'extra_data'} = 'extra_data' -> new ( filename => $parm,
 225                                                           target   => 'disk',
 226                                                           ignore_missing_files =>
 227                                                           $self -> {'ignore_missing_files'} );
 228         }
 229       }
 230 end extra_data_file_name
 231
 232 # }}}
 233
 234 # {{{ read_table_files
 235
 236 start _read_table_files
 237       {
 238         @{$self -> {'table_files'}} = ();
 239         my ( $table_name_ref, $junk ) = $self -> _option_val_pos( record_name => 'table',
 240                                                                   name        => 'FILE' );
 241         if ( defined $table_name_ref and scalar @{$table_name_ref} >= 0 ) {
 242           $self -> {'table_files'} = [];
 243           foreach my $table_name ( @{$table_name_ref} ) {
 244             'debug' -> warn( level => 2,
 245                              message => "Creating new table_file object from $table_name" );
 246             my $new_table = data -> new( directory            => $self -> {'directory'},
 247                                          filename             => $table_name,
 248                                          ignore_missing_files => $ignore_missing_files,
 249                                          target               => 'disk',
 250                                          table_file           => 1 );
 251             push( @{$self -> {'table_files'}}, $new_table );
 252           }
 253         }
 254       }
 255 end _read_table_files
 256
 257 # }}}
 258
 259 # {{{ add_records
 260 start add_records
 261     {
 262       # add_records( type => 'subroutine',
 263       #               record_strings => ['OTHER=get_cov', 'OTHER=read'] )
 264       # TODO change name from record to records.
 265
 266       # To read add a record, we figure out what its full class name
 267       # is. Then we check if we have an accessor for the record type,
 268       # if we do then the record is valid and we call the appropriate
 269       # contructor. Both record_strings an type are mandatory.
 270
 271       my $rec_class = "model::problem::$type";
 272       my $accessor = $type.'s';
 273       if( $self -> can($accessor) ){
 274         push( @{$self -> {$accessor}}, $rec_class -> new ( record_arr => \@record_strings ));
 275
 276       } else {
 277         'debug' -> die( message => "Trying to add unknown record: $type" );
 278       }
 279     }
 280 end add_records
 281 # }}} add_records
 282
 283 # {{{ covariance
 284 start covariance
 285       {
 286         my @records;
 287         if( defined $self -> {'covariances'} ) {
 288           @records = @{$self -> {'covariances'}} ;
 289         }
 290         if ( defined $enabled ) {
 291           if ( $enabled and $#records < 0 ) {
 292             $self -> add_records( type           => 'covariance',
 293                                   record_strings => [''] );
 294           } elsif ( not $enabled and $#records >= 0 ) {
 295             $self -> {'covariances'} = undef;
 296           }
 297         } else {
 298           if ( $#records >= 0 ) {
 299             $indicator = 1;
 300           } else {
 301             $indicator = 0;
 302           }
 303         }
 304       }
 305 end covariance
 306 # }}} covariance
 307
 308 # {{{ eigen
 309
 310 start eigen
 311       {
 312         my ( $print_ref, $position ) = $self -> _option_val_pos( record_name => 'covariance',
 313                                                              name        => 'PRINT' );
 314 #       print Dumper $print_ref;
 315 #       print Dumper $position;
 316 #       die;
 317 #       if ( defined $enabled ) {
 318 #         if ( $enabled and scalar @{$print_ref} < 1 ) {
 319 #       if (
 320       }
 321 end eigen
 322
 323 # }}} eigen
 324
 325 # {{{ header
 326 start header
 327       {
 328         my $inp_ref = $self -> inputs;
 329         if ( defined $inp_ref and defined $inp_ref -> [0] ) {
 330           my $input = $inp_ref -> [0];
 331           my $opt_ref = $input -> options;
 332           if ( defined $opt_ref ) {
 333             my @options = @{$opt_ref};
 334             foreach my $option ( @options ) {
 335               push ( @header, [$option -> name, $option -> value] );
 336             }
 337           }
 338         }
 339       }
 340 end header
 341 # }}} header
 342
 343 # {{{ indexes
 344
 345 start indexes
 346   # The Indexes method calculates the index for a parameter. Off-diagonal elements
 347   # will get a index 'i_j', where i is the row number and j is the column number
 348       {
 349         my $row = 1;
 350         my $accessor = $parameter_type.'s';
 351
 352         if( defined $self -> {$accessor} ){
 353
 354           # If we hit a "SAME" parameter we need to remember the
 355           # previous parameter size. ( calculated as "row - previous_row" )
 356
 357           my $previous_row = 0;
 358
 359           foreach my $record ( @{$self -> $accessor} ) {
 360             # If not a block or if the block is of size 1 use normal numbering
 361
 362             if( $record -> same ) {
 363
 364               if( $previous_row == 0 ){
 365                 'debug' -> die( message => "You can't have an $parameter_type estimate defined as SAME if it's the first estimate" );
 366               }
 367               my $size = $row - $previous_row;
 368               $previous_row = $row;
 369               for( 1..$size ){
 370                 push( @indexes, $row++);
 371               }
 372
 373             } elsif ( ( ! defined $record -> size ) or
 374                       ( $record -> size < 2 )) {
 375               if ( defined $record -> options ) {
 376                 $previous_row = $row;
 377                 foreach my $option ( @{$record -> options} ) {
 378                   push( @indexes, $row++ );
 379                 }
 380               }
 381             } else {
 382               # ... else use off-diagonal indexing where so is necessary
 383               my $size = $record -> size;
 384               for ( my $i = $row; $i <= $row + $size - 1; $i++ ) {
 385                 for ( my $j = $row; $j <= $i; $j++ ) {
 386                   if ( $j == $i ) {
 387                     push( @indexes, "$i" );
 388                   } else {
 389                     push( @indexes, "$i".'_'."$j" );
 390                   }
 391                 }
 392               }
 393               $previous_row = $row;
 394               $row += $size;
 395             }
 396           }
 397           if ( scalar @parameter_numbers > 0 ) {
 398             my @part_indexes = ();
 399             foreach my $num ( @parameter_numbers ) {
 400               if ( $num < 1 or $num > scalar @indexes ) {
 401                 'debug' -> die( message => "$parameter_type number " . $num . " does not exist in this model::problem\n" .
 402                                 "(" . scalar @indexes . " exists)\n" );
 403               }
 404               push( @part_indexes, $indexes[$num -1] );
 405             }
 406             @indexes = @part_indexes;
 407           } else {
 408             'debug' -> warn( level => 2,
 409                              message => "Model::problem -> indexes: parameter_numbers undefined, using all." );
 410           }
 411         }
 412       }
 413 end indexes
 414
 415 # }}} indexes
 416
 417 # {{{ nomegas
 418
 419 start nomegas
 420
 421 foreach my $omega ( @{$self -> {'omegas'}} ) {
 422   my $size = $omega -> size;
 423   if( defined $size ) {
 424
 425     # If the record has a size, it is of block form with diagonal of
 426     # length given by $size. The actual values in the model file is
 427     # then the arithmetic sum: (n*(n+1))/2
 428
 429     if( $with_correlations ){
 430       $nomegas += ($size*($size+1))/2;
 431
 432     # But we really only want the diagonal elements here:
 433     } else {
 434       $nomegas += $size;
 435     }
 436   } else {
 437     $nomegas += scalar @{$omega -> options};
 438   }
 439 }
 440
 441 end nomegas
 442
 443 # }}} nomegas
 444
 445 # {{{ nsigmas
 446
 447 start nsigmas
 448
 449 foreach my $sigma ( @{$self -> {'sigmas'}} ) {
 450   my $size = $sigma -> size;
 451   if( defined $size ) {
 452
 453     # If the record has a size, it is of block form with diagonal of
 454     # length given by $size. The actual values in the model file is
 455     # then the arithmetic sum: (n*(n+1))/2
 456
 457     if( $with_correlations ){
 458
 459       $nsigmas += ($size*($size+1))/2;
 460
 461     } else {
 462
 463       # But we really only want the diagonal elements here:
 464
 465       $nsigmas += $size;
 466     }
 467   } else {
 468     $nsigmas += scalar @{$sigma -> options};
 469   }
 470 }
 471
 472 end nsigmas
 473
 474 # }}} nsigmas
 475
 476 # {{{ primary_columns
 477
 478 start primary_columns
 479       {
 480         if ( defined $parm ) {
 481           my $inp_ref = $self -> inputs;
 482           if ( defined $inp_ref and defined $inp_ref -> [0] ) {
 483             $self -> inputs -> [0] -> options( [] );
 484           } else {
 485             $self -> inputs( ['input' -> new()] );
 486           }
 487           foreach my $arr_ref ( @{$parm} ) {
 488             my @col = @{$arr_ref};
 489             # It is important to keep (almost) all primary columns
 490             # undropped.  if one columns is dropped, all the data in
 491             # the same columns in the rows with CONT=1 will also be
 492             # dropped. In addition the indexing of EVTREC will be
 493             # wrong. The only exception to this are the DAT(E|1|2|3)
 494             # columns. The must be dropped because the NONMEM data set
 495             # may not include non-digits. To handle this, these
 496             # columns will be only include dummy variables in the
 497             # secondary_columns attribute.
 498             my $value;
 499 #           if( $col[2] eq 'DROP' ) {
 500 #             $value = undef;
 501 #           } else {
 502 #             $value = $col[2];
 503         #    }
 504 #           print "N: $col[0], V: $col[2]\n";
 505             my $value = $col[0] =~ /DAT(E|1|2|3)/ ? $col[2] : undef;
 506             $self -> inputs -> [0] -> add_option ( init_data => { name  => $col[0],
 507                                                                   value => $value } );
 508           }
 509           $self -> contify_tables;
 510         }
 511       }
 512 end primary_columns
 513
 514 # }}} primary_columns
 515
 516 # {{{ secondary_columns
 517
 518 start secondary_columns
 519       {
 520         if ( defined $parm ) {
 521           if ( defined $self -> pks ) {
 522             $self -> pks -> [0] -> secondary_columns($parm);
 523           }
 524           if ( defined $self -> preds ) {
 525             $self -> preds -> [0] -> secondary_columns($parm);
 526           }
 527           if ( defined $self -> errors ) {
 528             $self -> errors -> [0] -> secondary_columns($parm);
 529           }
 530           # This is a lengthy bit of code to create a reasonable header and secondary
 531           # columns for the table files. When the data file of the problem is wrapped
 532           # using the CONT data item, the rows of the table files will be duplicated (or
 533           # at least, only every second or third row will hold the table output).
 534           if( defined $self -> {'tables'} ){
 535             for( my $i = 0; $i < scalar @{$self -> {'tables'}}; $i++ ) {
 536               if( defined $self -> {'table_files'} and defined $self -> {'table_files'}[$i] ) {
 537 #             my $table = $self -> {'tables'}[$i]; # $TABLE
 538                 my $table_file = $self -> {'table_files'}[$i]; # The actual file
 539 #             my $cont_column = $table_file -> cont_column;
 540 #             my @options = @{$table -> options};
 541 #             my @header_options;
 542 #             for( my $j = 1; $j <= scalar @options; $j++ ) {
 543 #               my $option = $options[$j-1];
 544 #               my $name = $option -> name;
 545 #               last if( $name eq 'BY' or  $name eq 'PRINT' or $name eq 'NOPRINT' or
 546 #                        $name eq 'FILE' or $name eq 'NOHEADER' or $name eq 'ONEHEADER' or
 547 #                        $name eq 'FIRSTONLY' or $name eq 'NOFORWARD' or $name eq 'FORWARD' or
 548 #                        $name eq 'APPEND' or $name eq 'NOAPPEND' or $name eq 'UNCONDITIONAL' or
 549 #                        $name eq 'CONDITIONAL' or $name eq 'OMITTED' );
 550 #               push( @header_options, $option );
 551 #             }
 552 #             my $nopt = scalar @header_options;
 553 #             my @sec;
 554 #             my @header;
 555 #             if( defined $cont_column and ref( $parm ) eq 'ARRAY' and scalar @{$parm} > 0 ) {
 556 #               for( my $k = -1; $k < scalar @{$parm}; $k++ ) {
 557 #                 my @in_sec;
 558 #                 my $pos = 1;
 559 #                 for( my $j = 1; $j <= $nopt; $j++ ) {
 560 #                   my $option = $header_options[$j-1];
 561 #                   my $name = $option -> name;
 562 #                   my $glob_pos;
 563 #                   if( $name ne 'CONT' ) {
 564 #                     $name = $k == -1 ? $name : $name.($k+1);
 565 #                     $glob_pos = (($nopt-1)*($k+1))+$pos++;
 566 #                     push( @header, $name );
 567 #                   }
 568 #                   next if ( $k == -1 );
 569 #                   my @col = ( $name, $glob_pos, $option -> value );
 570 #                   push( @in_sec, \@col );
 571 #                 }
 572 #                 unshift( @sec, \@in_sec );
 573 #               }
 574 #             }
 575                 $table_file -> header( [] );
 576 #             $table_file -> header( \@header );
 577 #             $table_file -> secondary_columns( \@sec );
 578               }
 579             }
 580           }
 581         } else {
 582           if ( defined $self -> pks ) {
 583             $self -> {'secondary_columns'} = $self -> pks -> [0] -> secondary_columns();
 584           } else {
 585             $self -> {'secondary_columns'} = $self -> preds -> [0] -> secondary_columns();
 586           }
 587         }
 588       }
 589 end secondary_columns
 590
 591 # }}} secondary_columns
 592
 593 # {{{ record_count
 594 start record_count
 595     {
 596         $return_value = 0;
 597         if( defined $self -> {$record_name . 's'} ){
 598             foreach my $record ( @{$self -> {$record_name . 's'}} ){
 599                 if( defined $record -> options ){
 600                     $return_value += @{$record -> options};
 601                 }
 602             }
 603         }
 604     }
 605 end record_count
 606 # }}} record_count
 607
 608 # {{{ restore_inits
 609 start restore_inits
 610       {
 611         if ( defined $self -> {'thetas'} ) {
 612           foreach my $theta ( @{$self -> {'thetas'}} ) {
 613             $theta -> restore_inits;
 614           }
 615         }
 616         if ( defined $self -> {'omegas'} ) {
 617           foreach my $omega ( @{$self -> {'omegas'}} ) {
 618             $omega -> restore_inits;
 619           }
 620         }
 621         if ( defined $self -> {'sigmas'} ) {
 622           foreach my $sigma ( @{$self -> {'sigmas'}} ) {
 623             $sigma -> restore_inits;
 624           }
 625         }
 626       }
 627 end restore_inits
 628 # }}} restore_inits
 629
 630 # {{{ set_random_inits
 631 start set_random_inits
 632       {
 633         if ( defined $self -> {'thetas'} ) {
 634           foreach my $theta ( @{$self -> {'thetas'}} ) {
 635             $theta -> set_random_inits( degree => $degree );
 636           }
 637         }
 638         if ( defined $self -> {'omegas'} ) {
 639           foreach my $omega ( @{$self -> {'omegas'}} ) {
 640             $omega -> set_random_inits( degree => $degree );
 641           }
 642         }
 643         if ( defined $self -> {'sigmas'} ) {
 644           foreach my $sigma ( @{$self -> {'sigmas'}} ) {
 645             $sigma -> set_random_inits( degree => $degree );
 646           }
 647         }
 648       }
 649 end set_random_inits
 650 # }}} set_random_inits
 651
 652 # {{{ set_records
 653
 654 start set_records
 655       {
 656           my $rec_class = "model::problem::$type";
 657           my $accessor = $type.'s';
 658           if( $self -> can($accessor) ){
 659             $self -> {$accessor} = [$rec_class -> new ( record_arr => \@record_strings) ];
 660           } else {
 661               die "Error in problem -> set_records: Trying to set unknown record: $type\n";
 662           }
 663       }
 664 end set_records
 665
 666 # }}} set_records
 667
 668 # {{{ remove_records
 669 start remove_records
 670       {
 671           my $rec_class = "model::problem::$type";
 672           my $accessor = $type.'s';
 673           if( $self -> can($accessor) ){
 674               $self -> {$accessor} = undef;
 675           } else {
 676               die "Error in problem -> remove_records: Trying to remove unknown record: $type\n";
 677           }
 678       }
 679 end remove_records
 680 # }}} remove_records
 681
 682 # {{{ add_option
 683
 684 start add_option
 685
 686 my $accessor = $record_name.'s';
 687 unless( $self -> can($accessor) ){
 688   'debug' -> die( message => "Unknown record name: $record_name" );
 689 }
 690 if( defined $self -> {$accessor} ) {
 691   my @records = @{$self -> {$accessor}};
 692   foreach my $record ( @records ) {
 693     $record -> add_option( init_data => { name  => $option_name,
 694                                           value => $option_value } );
 695   }
 696 } else {
 697   if( $add_record ) {
 698     $self -> add_records( type           => $record_name,
 699                           record_strings => ["$option_name=$option_value"] );
 700   } else {
 701     'debug' ->  warn( level => 2,
 702                       message => "No records of type $accessor and add_option ".
 703                       "set not to add one" );
 704   }
 705 }
 706
 707 end add_option
 708
 709 # }}} add_option
 710
 711 # {{{ remove_option
 712
 713 start remove_option
 714
 715 my $accessor = $record_name.'s';
 716 unless( $self -> can($accessor) ){
 717   'debug' -> die( message => "Unknown record name: $record_name" );
 718 }
 719 if( defined $self -> {$accessor} ) {
 720   my @records = @{$self -> {$accessor}};
 721   foreach my $record ( @records ) {
 722     $record -> remove_option( name => $option_name,
 723                               fuzzy_match => $fuzzy_match );
 724   }
 725 } else {
 726   'debug' ->  warn( level => 2,
 727                     message => "No records of type $accessor" );
 728 }
 729
 730 end remove_option
 731
 732 # }}} remove_option
 733
 734 # {{{ store_inits
 735 start store_inits
 736       {
 737         if ( defined $self -> {'thetas'} ) {
 738           foreach my $theta ( @{$self -> {'thetas'}} ) {
 739             $theta -> store_inits;
 740           }
 741         }
 742         if ( defined $self -> {'omegas'} ) {
 743           foreach my $omega ( @{$self -> {'omegas'}} ) {
 744             $omega -> store_inits;
 745           }
 746         }
 747         if ( defined $self -> {'sigmas'} ) {
 748           foreach my $sigma ( @{$self -> {'sigmas'}} ) {
 749             $sigma -> store_inits;
 750           }
 751         }
 752       }
 753 end store_inits
 754 # }}} store_inits
 755
 756 # {{{ _format_problem
 757
 758 start _format_problem
 759       {
 760         # problem::_format_problem()
 761
 762         # format_problem will return an array of strings of the
 763         # problem in NONMEM modelfile format.
 764
 765         # Loop over the print_order array that contains strings of
 766         # valid record types in the order they should appear in a
 767         # NONMEM modelfile. So if the order of some records are
 768         # interchangable and the file from which the object was
 769         # initialized has records in an order different from
 770         # print_order, the file will still be valid, but will look
 771         # different from what it used to.
 772         my $record_order = $self -> {'sde'} ? \@sde_print_order : \@print_order;
 773         foreach my $type ( @${record_order} ) {
 774           # Create an accessor string for the record being formatted
 775           my $accessor = $type.'s';
 776
 777           # Se if we have one or more records of the type given in
 778           # print_order
 779           if ( defined $self -> {$accessor} ) {
 780             # Loop over all such records and call on the record object
 781             # to format itself.
 782             foreach my $record ( @{$self -> {$accessor}} ){
 783               push( @formatted,
 784                     @{$record ->
 785                           _format_record( nonparametric_code => $self -> {'nonparametric_code'},
 786                                           shrinkage_code     => $self -> {'shrinkage_code'},
 787                                           eigen_value_code   => $self -> {'eigen_value_code'} ) } );
 788             }
 789           }
 790           if( $self -> {'shrinkage_module'} -> enabled and $type eq 'table' ) {
 791             push( @formatted,
 792                   @{$self -> {'shrinkage_module'} -> format_shrinkage_tables } );
 793           }
 794         }
 795
 796         if( $self -> {'cwres_modules'} ){
 797           $self -> {'cwres_modules'} -> [0] -> post_process;
 798         }
 799
 800       }
 801 end _format_problem
 802
 803 # }}} _format_problem
 804
 805 # {{{ _init_attr
 806
 807 start _init_attr
 808       {
 809         # Private method, should preferably not be used outside model.pm
 810         # The add_if_absent argument tells the method to add an init (theta,omega,sigma)
 811         # if the parameter number points to a non-existing parameter with parameter number
 812         # one higher than the highest presently included. Only applicatble if
 813         # new_values are set. Default value = 0;
 814
 815         my $accessor = $parameter_type.'s';
 816         unless( $self -> can($accessor) ){
 817             'debug' -> die( message => "problem -> _init_attr: Error unknown parameter type: $parameter_type" );
 818         }
 819
 820         my @records;
 821         if( defined $self -> {$accessor} ){
 822           @records = @{$self -> {$accessor}};
 823         } else {
 824           @records = ();
 825         }
 826
 827         my @options = ();
 828
 829         # {{{ Check that the size of parameter_numbers and new_values match
 830         my %num_val;
 831         if ( $#parameter_numbers >= 0 and $#new_values >= 0 ) {
 832           if ( $#parameter_numbers == $#new_values ) {
 833             for ( my $i = 0; $i <= $#new_values; $i++ ) {
 834               $num_val{$parameter_numbers[$i]} = $new_values[$i];
 835             }
 836           } else {
 837             die "Model::problem -> _init_attr: The number of specified ".
 838               "parameters (@parameter_numbers) and values (@new_values) do not match for parameter $parameter_type".
 839                 " and attribute $attribute\n";
 840           }
 841         }
 842         # }}}
 843
 844         my $prev_size = 1;
 845         if ( scalar @new_values > 0 ) {
 846           # {{{ Update values
 847
 848           # OBS! We are using 'normal' numbering in parameter_numbers, i.e. they begin
 849           # at one (1).
 850           my $opt_num = 1;
 851           # Ugly solution to add non-existing options:
 852           my %found;
 853           foreach my $num ( @parameter_numbers) {
 854 #           print "inpn: $num\n";
 855             $found{$num} = 0;
 856           }
 857
 858           my @diagnostics = ();
 859           foreach my $record ( @records ) {
 860             if ( $record -> same() ) {
 861               # SAME == true: Nothing to be done. Just move forward to next $OMEGA but
 862               # increase counter first
 863
 864               $opt_num += $prev_size;
 865             } else {
 866               foreach my $option ( @{$record -> options} ) {
 867                 if ( scalar @parameter_numbers > 0 ) {
 868                   foreach my $num ( @parameter_numbers ) {
 869                     if ( $num == $opt_num ) {
 870                       $found{$num}++;
 871                       if ( $attribute eq 'init' ) {
 872                         push( @diagnostics,
 873                               $option -> check_and_set_init( new_value => $num_val{$num} ) );
 874                       } elsif( $attribute eq 'fix' and defined $record -> size() ){
 875                         # size() tells us this is a block and we must fix on record level.
 876                         $record -> fix( $num_val{$num} );
 877                       } else {
 878                         $option -> $attribute( $num_val{$num} );
 879                       }
 880                     }
 881                   }
 882                 } else {
 883                   if ( $attribute eq 'init' ) {
 884                     push( @diagnostics,
 885                           $option -> check_and_set_init( new_value => shift( @new_values ) ) );
 886                   } elsif( $attribute eq 'fix' and defined $record -> size() ){
 887                     # size() tells us this is a block and we must fix on record level.
 888                     $record -> fix( shift( @new_values ) );
 889                   } else {
 890                     $option -> $attribute( shift( @new_values ) );
 891                   }
 892                 }
 893                 $opt_num++;
 894               }
 895               if( $parameter_type eq 'theta' ){
 896                 $prev_size = scalar @{$record -> options};
 897               } else {
 898                 my $size = $record -> size;
 899                 if( defined $size ) {
 900                   $prev_size = ($size*($size+1))/2;
 901                 } else {
 902                   $prev_size = scalar @{$record -> options};
 903                 }
 904               }
 905             }
 906           }
 907           # If $add_if_absent is set, any parameters that were not found above are
 908           # added below:
 909
 910           my @nums = sort {$a<=>$b} keys %found;
 911           my $new_record = "model::problem::$parameter_type" -> new();
 912           my $do_add_record;
 913           foreach my $num ( @nums ) {
 914             if ( $add_if_absent and
 915                  not $found{$num} ) {
 916               $do_add_record = 1;
 917               unless($num == $opt_num) {
 918                 'debug' -> die( message => "Attempt to add a parameter with higher number ($num) than the number\n".
 919                                            "of parameters + 1 ($opt_num)\n" );
 920               }
 921               # Get the last record of $parameter_type
 922               # my $new_record = $records[$#records];
 923               my $option_class;
 924               if( $parameter_type eq 'theta' ){
 925                 $option_class = 'model::problem::record::theta_option';
 926               } else {
 927                 $option_class = 'model::problem::record::init_option';
 928               }
 929
 930               # Push a new option to this last record
 931               my $option = $option_class -> new;
 932               if ( $attribute eq 'init' ) {
 933                 $option -> check_and_set_init( new_value => $num_val{$num} );
 934               } elsif( $attribute eq 'fix' and defined $new_record -> size() ){
 935
 936                 # size() tells us this is a block and we must fix on
 937                 # record level. This will never happen, as we can't
 938                 # add BLOCKS, at least not like this.
 939
 940                 $new_record -> fix( $num_val{$num} );
 941               } else {
 942                 $option -> $attribute( $num_val{$num} );
 943               }
 944               push( @{$new_record -> {'options'}}, $option );
 945
 946               # So we've added a parameter. Possible to add more,
 947               # lets increase the highest found:
 948               $opt_num++;
 949             }
 950           }
 951           if ( $attribute eq 'init' ) {
 952             # We're updating but might be returning diagnostics
 953             # Use the default return parameter parameter_values for this
 954             @parameter_values = @diagnostics;
 955           }
 956
 957           if( $do_add_record ){
 958             push( @records, $new_record );
 959             $self -> {$accessor} = \@records ;
 960           }
 961
 962           # }}} Update values
 963         } else {
 964           # {{{ Retrieve values
 965
 966           my @prev_values = ();
 967           foreach my $record ( @records ) {
 968             unless ( $record -> same() ) {
 969               @prev_values = ();
 970               if ( defined $record -> options ) {
 971                 foreach my $option ( @{$record -> options} ) {
 972                   push( @prev_values, $option -> $attribute );
 973                 }
 974               } else {
 975                 'debug' -> warn( level   => 1,
 976                                  message => "Trying to get attribute $attribute, ".
 977                                  "but no options defined in record ".ref($record) );
 978               }
 979               $prev_size = $record -> size unless ( $record -> same );
 980             }
 981             # I am not confortable with the action below, i.e. to just
 982             # append the previous value of the attribute if the record
 983             # is SAME. An exception is made to labels. Maybe this
 984             # should be the default?
 985             if( $record -> same() ) {
 986               for( my $i = 0; $i <= $#prev_values; $i++ ) {
 987                 $prev_values[$i] = undef;
 988               }
 989             }
 990             push( @parameter_values, @prev_values );
 991           }
 992
 993           if ( scalar @parameter_numbers > 0 ) {
 994             my @part_vals = ();
 995             foreach my $num ( @parameter_numbers ) {
 996               push( @part_vals, $parameter_values[$num -1] );
 997             }
 998             @parameter_values = @part_vals;
 999           } else {
1000             'debug' -> warn( level => 2,
1001                              message => "Model::problem -> _init_attr: parameter_numbers undefined, using all." );
1002           }
1003
1004           # }}} Retrieve values
1005         }
1006       }
1007 end _init_attr
1008
1009 # }}} _init_attr
1010
1011 # {{{ name_val
1012
1013 start name_val
1014 #       {
1015 #       my $accessor = $parameter_type.'_name_vals';
1016 #       unless( $self -> can($accessor) ){
1017 #           die "problem -> _init_attr: Error unknown parameter type: $parameter_type\n";
1018 #       }
1019 #       print "P: $parameter_type\n" if $self -> {'debug'};
1020 #       print "Model::problem -> _init_attr: parameter_type: $parameter_type\n"
1021 #           if $self -> {'debug'};
1022 #       my @records = @{$self -> {$accessor}};
1023 #       my @options = ();
1024
1025 #       my $prev_size = 1;
1026 #       # {{{ Retrieve values
1027 #       foreach my $record ( @records ) {
1028 #         foreach my $option ( @{$record -> options} ) {
1029 #           if ( $record -> same ) {
1030 #             for ( my $i = 1; $i <= $prev_size*($prev_size+1)/2 ; $i++ ) {
1031 #               push( @parameter_values, @{$record -> options}[0] -> $attribute );
1032 #             }
1033 #           } else {
1034 #             push( @parameter_values, $option -> $attribute );
1035 #           }
1036 #         }
1037 #         $prev_size = $record -> size unless ( $record -> same );
1038 #       }
1039 #       if ( $#parameter_numbers > 0 ) {
1040 #         my @part_vals = ();
1041 #         foreach my $num ( @parameter_numbers ) {
1042 #           push( @part_vals, $parameter_values[$num -1] );
1043 #         }
1044 #         @parameter_values = @part_vals;
1045 #       } else {
1046 #         print "Model::problem -> _init_attr: parameter_numbers undefined, using all.\n" if
1047 #           $self -> {'debug'};
1048 #       }
1049 #       # }}} Retrieve values
1050 #       }
1051 end name_val
1052
1053 # }}} name_val
1054
1055 # {{{ _normalize_record_name
1056
1057 start _normalize_record_name
1058     {
1059
1060       # This code takes a recordname (which likely is uppercase and
1061       # semilong), creates its short uppercase format and looks up the
1062       # long, lowercase, name in the abbreviations hash that was
1063       # initialized in "new". The name is assumed to be valid, if its
1064       # not, an empty string will be returned, but no error produced (
1065       # a warning might be nice though ) (Errorhandling is now done in
1066       # "read_records".
1067
1068       my $uc_short_type = substr(uc($record_name),0,3);
1069       $uc_short_type = $uc_short_type.' ' if ( $record_name eq 'aes' );
1070       $uc_short_type = $uc_short_type.'I' if ( $record_name eq 'aesinit' );
1071       $normalized_name = $abbreviations{$uc_short_type};
1072     }
1073 end _normalize_record_name
1074
1075 # }}}
1076
1077 # {{{ _read_records
1078
1079 start _read_records
1080     {
1081
1082       # We parse the lines of a problem by looping over the them and
1083       # look for records(lines starting with a $). When a record is
1084       # found we set its index in the array as the end of the previous
1085       # record we found. We then know which lines to send to the
1086       # record object constructor. Then we set the end index of the
1087       # previous record as the start index of the next record. It is
1088       # assumed that the first record starts at line zero. The end of
1089       # the last record is the last line.
1090
1091       my $start_index = 0;
1092       my $record_index = 0;
1093       my $end_index;
1094       my $first = 1;
1095
1096       # It may look like the loop takes one step to much, but its a
1097       # trick that helps parsing the last record.
1098       for( my $i = 0; $i <= @{$self -> {'prob_arr'}}; $i++ ){
1099
1100         # This if statement makes sure we dont access the array in the
1101         # last iteration of the loop. In all other iterations we need
1102         # a line of code to look for records starting lines.
1103
1104         if( $i <= $#{$self -> {'prob_arr'}} ){
1105           $_ = $self -> {'prob_arr'} -> [$i];
1106         }
1107
1108         # In this if statement we use the lazy evaluation of logical
1109         # or to make sure we only execute search pattern when we have
1110         # a line to search. Which is all cases but the very last loop
1111         # iteration.
1112
1113         if( $i > $#{$self -> {'prob_arr'}} or /^\s*\$(\w+)/ ){
1114           $end_index = $i;
1115
1116           # The if statement here is only necessary in the first loop
1117           # iteration. When start_index == end_index == 0 we want to
1118           # skip to the next iteration looking for the actual end of
1119           # the first record.
1120
1121           if( $end_index > $start_index and not $first){
1122             # extract lines of code:
1123             my @record_lines = @{$self -> {'prob_arr'}}[$start_index .. $end_index-1];
1124             # extract the record name and get its long name:
1125             $self -> {'prob_arr'} -> [$record_index] =~ /^\s*\$(\w+)/;
1126             my $record_name = $1;
1127             my $record_type = $self -> _normalize_record_name( record_name => $record_name );
1128
1129             unless( length($record_type) > 0 ){
1130               'debug' -> die( message => "Record $record_name is not valid" );
1131             }
1132
1133             # reset the search for records by moving the record start
1134             # forwards:
1135             $start_index = $i;
1136
1137             # let add_records create the object if appropriate
1138
1139             if( $record_type eq 'table' ) {
1140               my $et_found = 0;
1141               my $wr_found = 0;
1142               my $eta_name  = $self -> {'shrinkage_module'} -> eta_tablename;
1143               my $wres_name = $self -> {'shrinkage_module'} -> wres_tablename;
1144               foreach my $row ( @record_lines ) {
1145                 $et_found++ if( $row =~ /$eta_name/ );
1146                 $wr_found++ if( $row =~ /$wres_name/ );
1147               }
1148               if( $et_found or $wr_found ) {
1149                 $self -> {'shrinkage_module'} -> enable;
1150               } else {
1151                 $self -> add_records( record_strings => \@record_lines,
1152                                       type => $record_type );
1153               }
1154             } else {
1155               $self -> add_records( record_strings => \@record_lines,
1156                                     type => $record_type );
1157             }
1158           }
1159           $first = 0;
1160           $record_index = $i;
1161         }
1162       }
1163     }
1164 end _read_records
1165
1166 # }}} _read_records
1167
1168 # {{{ _option_val_pos
1169
1170 start _option_val_pos
1171       {
1172         #
1173         # _option_val_pos( record_name => 'subroutine',
1174         #                  name => 'OTHER',
1175         #                  val => 'get_cov')
1176         #
1177
1178         # _option_val_pos sets, or gets, the value of an option (given
1179         # as the 'name' parameter. Name must be uppercase) in a record
1180         # (given as the 'record_name' parameter. Record name should be
1181         # the record class name in the model diagram.)
1182
1183         my $accessor = $record_name.'s';
1184         unless( $self -> can($accessor) ){
1185           'debug' -> die( message => "Unknown record name: $record_name" );
1186         }
1187
1188         my @records;
1189         if( defined $self -> {$accessor} ) {
1190           @records = @{$self -> {$accessor}} ;
1191         } else {
1192           'debug' ->  warn( level => 2,
1193                             message => "No records of type $accessor" );
1194           @records = ();
1195         }
1196         my @options = ();
1197
1198         # {{{ Check that the size of instance_numbers and new_values match
1199
1200         my %num_val;
1201         if ( $#instance_numbers >= 0 and $#new_values >= 0 ) {
1202           if ( $#instance_numbers == $#new_values ) {
1203             for ( my $i = 0; $i <= $#new_values; $i++ ) {
1204               $num_val{$instance_numbers[$i]} = $new_values[$i];
1205             }
1206           } else {
1207             'debug' -> die( message => "Model::problem -> _option_val_pos: The number of specified " .
1208                             "parameters " . $#instance_numbers+1 . " and values " .
1209                             $#new_values+1 . " do not match" );
1210           }
1211         }
1212
1213         # }}}
1214
1215         if ( scalar @new_values > 0 ) {
1216           # {{{ Update values
1217
1218           my $opt_num = 1;
1219           foreach my $record ( @records ) {
1220             foreach my $option ( @{$record -> options} ) {
1221               my $test_name = $exact_match ? uc($option -> name) :
1222                   uc(substr($option -> name,0,length($name)));
1223               if ( $test_name eq $name) {
1224                 if ( scalar @instance_numbers > 0 ) {
1225                   foreach my $num ( @instance_numbers ) {
1226                     $option -> value( $num_val{$num} ) if $num == $opt_num;
1227                   }
1228                 } else {
1229                   $option -> value( shift( @new_values ) );
1230                 }
1231                 $opt_num++;
1232               }
1233             }
1234           }
1235
1236           # }}} Update values
1237         } else {
1238           # {{{ Retrieve values
1239
1240           foreach my $record ( @records ) {
1241             my $i = 1;
1242             if ( defined $record -> options ) {
1243               foreach my $option ( @{$record -> options} ) {
1244                 my $test_name = $exact_match ? uc($option -> name) :
1245                   uc(substr($option -> name,0,length($name)));
1246                 if ( $test_name eq $name) {
1247                   push( @values, $option -> value );
1248                   push( @positions, $i );
1249                 }
1250                 $i++;
1251               }
1252             }
1253           }
1254           if ( $#instance_numbers > 0 ) {
1255             my @part_vals = ();
1256             my @part_pos = ();
1257             foreach my $num ( @instance_numbers ) {
1258               push( @part_vals, $values[$num -1] );
1259               push( @part_pos, $positions[$num -1] );
1260             }
1261             @values = @part_vals;
1262             @positions = @part_pos;
1263           }
1264
1265           # }}} Retrieve values
1266         }
1267       }
1268 end _option_val_pos
1269
1270 # }}} _option_val_pos
1271
1272 # {{{ eta_shrinkage
1273
1274 start eta_shrinkage
1275
1276 @eta_shrinkage = @{$self -> {'shrinkage_module'} -> eta_shrinkage};
1277
1278 end eta_shrinkage
1279
1280 # }}} eta_shrinkage
1281
1282 # {{{ wres_shrinkage
1283
1284 start wres_shrinkage
1285
1286 @wres_shrinkage = @{$self -> {'shrinkage_module'} -> wres_shrinkage};
1287
1288 end wres_shrinkage
1289
1290 # }}} wres_shrinkage