lib/tool_subs.pm

   1 # {{{ include
   2
   3 start include statements
   4 use ext::Parallel::ForkManager;
   5 use strict;
   6 use Cwd;
   7 use File::Copy 'cp';
   8 use OSspecific;
   9 use Storable;
  10 use Math::Random;
  11 use ui;
  12 use Data::Dumper;
  13 use Config;
  14 our $AUTOLOAD;
  15 if ( $PsN::config -> {'_'} -> {'use_database'} ) {
  16 # Testing DBD::mysql:
  17   require DBI;
  18 }
  19 end include
  20
  21 # }}} include statements
  22
  23 # {{{ new
  24
  25 start new
  26 {
  27     # The I<retries>, I<picky>, I<nm_version>, I<seed> and I<threads>
  28     # attributes can be specified as either a scalar or as an
  29     # array. The scalar value will be applied to all models whereas
  30     # the array holds values per model. If an array is given it must
  31     # be of the same length as the number of models.
  32     #
  33     # The I<directory> is the folder where the tools stores
  34     # temporary data and runs subtools (or in the modelfit case,
  35     # runs NONMEM). If unsure of what this means, leave it undefined
  36     # and a default will be used, e.g. modelfit_dir3 or something.
  37     #
  38     # The base_directory refers to the directory where the tool
  39     # should place its own directory. Default is current directory.
  40     #
  41     # A more interresting attribute is I<threads> which sets how many
  42     # parallel executions of NONMEM that will run. Some tips are:
  43     # Setting the number of threads higher than the number of nodes in
  44     # your cluster/supercomputer can make your runs slower. The
  45     # biggest limiting factor is the amount of memory needed by
  46     # NONMEM. With smaller runs, just set the thread number to the
  47     # number of nodes available.
  48     #
  49     # The I<directory> is the folder where the tools stores
  50     # temporary data and runs subtools (or in the modelfit case,
  51     # runs NONMEM). Each NONMEM run will have its own sub directory
  52     # NM_run[X] where [X] is an index running from 0 to the number of
  53     # runs-1. If unsure of what this means, leave it undefined and a
  54     # default will be used, e.g. modelfit_dir3 or something.
  55     #
  56     # Next, the I<compress> attribute are good
  57     # if you want to save some hard disk space. I<compress> set to 1
  58     # will put all NONMEM output in to an tar/gz archive named
  59     # I<problem_files.tgz> placed in the I<NM_run[X]> directory
  60     # described above.
  61     #
  62     # I<retries> is the number of times L</run> will alter initial
  63     # values and (re)execute NONMEM when executions fail. I<retries>
  64     # can either be an integer, specifying the number of retries for
  65     # all models, or it can be an array with the number of retries
  66     # specific for each modelfile as elements. The default value is
  67     # B<5>. The algorithm for altering the initial values works
  68     # roughly like this: For each each new try, a random new initial
  69     # value is drawn from a uniform distribution with limits +-n*10%
  70     # of the original intial estimate and where n i equal to the retry
  71     # number. I.e. the first retry, the borders of the distribution
  72     # are +-10%. The algorithm ensures that the new values are within
  73     # specified boundaries.
  74     #
  75     # =begin html
  76     #
  77     # For a full dexcription of the algorithm, see <a
  78     # href="model/problem/record/init_option.html#set_random_init">set_random_init</a>
  79     # of the <a
  80     # href="model/problem/record/init_option.html">init_option
  81     # class</a>.
  82     #
  83     # =end html
  84     #
  85     # =begin man
  86     #
  87     # For a full dexcription of the algorithm, see I<set_random_init>
  88     # of the I<init_option> class.
  89     #
  90     # =end man
  91     #
  92     # If I<picky> is set to 1, the output from NONMEM will be checked
  93     # more thoroughly. If any of the lines below are found in the
  94     # minimization message, a rerun is initiated.
  95     #
  96     #    ESTIMATE OF THETA IS NEAR THE BOUNDARY AND
  97     #    PARAMETER ESTIMATE IS NEAR ITS BOUNDARY
  98     #    R MATRIX ALGORITHMICALLY SINGULAR
  99     #    S MATRIX ALGORITHMICALLY SINGULAR
 100     #
 101     # I<nm_version> is a string with the version number of NONMEM that
 102     # will be used. The installed versions of NONMEM must be specified
 103     # in OSspecific.pm, the class responsible for system specific
 104     # features settings.
 105     #
 106     # I<logfile> specifies the name of the logfile.
 107     #
 108     # If I<debug> is set to 1(true), (many!) debug messages will be
 109     # printed.
 110     #
 111     # I<extra_files> is an array of strings where each string is a
 112     # file needed for NONMEM execution. Those file will be moved
 113     # to the I<NM_run[X]> directory.
 114     #
 115     # I<seed> is just a way to set a seed number.
 116     #
 117     # If a directory is given as argument to a tool, it will extract
 118     # all information about what has already been run in this
 119     # directory and continue there. If nothing is left to do, it will
 120     # still produce the output as a normal run would. This is useful
 121     # both for resuming crashed runs as well as for extracting
 122     # information form an old run.
 123
 124   $this -> {'seed'} = defined $parm{'seed'} ? $parm{'seed'} : random_uniform_integer(1,0,10000000);
 125
 126         #Initiate the random generator if a seed is given (which it is, see above)
 127         random_set_seed_from_phrase( $this -> {'seed'} );
 128
 129         # The base_directory refers to the directory where the tool should place its own
 130         # directory
 131         if ( defined $parm{'base_directory'} ) {
 132           $this -> {'base_directory'} = $parm{'base_directory'};
 133         } else {
 134           my ($uniquePath, $file) = OSspecific::absolute_path( '', '' );
 135           $this -> {'base_directory'} = $uniquePath;
 136         }
 137
 138         my @tool_name_full = split( '::', ref $this );
 139         my $tool_name = $tool_name_full[$#tool_name_full];
 140
 141         # The directory is the folder where the tools stores temporary data and
 142         # runs subtools (or in the modelfit case, runs NONMEM)
 143         if ( defined $parm{'directory'} ) {
 144           my $dummy;
 145           ( $this -> {'directory'}, $dummy ) = OSspecific::absolute_path( $parm{'directory'}, '');
 146         } else {
 147           my $file;
 148           $this -> {'directory'} =
 149               OSspecific::unique_path( $tool_name.'_dir' ,
 150                                        $this -> {'base_directory'} );
 151         }
 152
 153
 154   # Create my temporary directory
 155   $this -> _make_dir;
 156   if ( $PsN::config -> {'_'} -> {'use_database'} ) {
 157     my( $found_log, $found_tool_id ) = $this -> read_log;
 158
 159     $this -> register_in_database unless ( $found_tool_id );
 160
 161     $this -> log_object unless ( $found_log and $found_tool_id );
 162   }
 163
 164         debug -> die( message => "No model specified!" )
 165             unless ( defined $this -> {'models'} and scalar @{$this -> {'models'}} > 0 );
 166         foreach my $mod ( @{$this -> {'models'}} ) {
 167           debug -> die( message => "Supplied argument model is not defined" )
 168               unless defined $mod;
 169         }
 170         # Make sure that the filenames are absolute and collect model_ids
 171         my @model_ids;
 172         foreach my $model ( @{$this -> {'models'}} ) {
 173           my $model_id = $model -> model_id;
 174           if( not defined $model_id ) {
 175             $model_id = $model -> register_in_database;
 176           }
 177           my $datas = $model -> datas;
 178           if( defined $datas ) {
 179             foreach my $data ( @{$datas} ) {
 180               my $data_id = $data -> data_id;
 181               if( not defined $data_id ) {
 182                 $data -> register_in_database;
 183               }
 184             }
 185           }
 186
 187           push( @model_ids, $model -> model_id );
 188             my ($directory, $filename) = OSspecific::absolute_path( $model -> directory, $model -> filename );
 189             $model -> filename( $filename );
 190             $model -> directory( $directory );
 191           if ( defined $model -> outputs ) {
 192             my @outputs = @{$model -> outputs};
 193             foreach my $output ( @outputs ) {
 194                 my ($directory, $filename) = OSspecific::absolute_path( $outputs[0] -> directory, $outputs[0] -> filename );
 195                 $output -> filename( $filename );
 196                 $output -> directory( $directory );
 197             }
 198           }
 199           if ( defined $model -> datas ) {
 200             my @datas = @{$model -> datas};
 201             foreach my $data ( @datas ) {
 202                 my ($directory, $filename) = OSspecific::absolute_path( $datas[0] -> directory, $datas[0] -> filename );
 203                 $data -> filename( $filename );
 204                 $data -> directory( $directory );
 205             }
 206           }
 207         }
 208   $this -> {'model_ids'} = \@model_ids;
 209   if ( not -e $this -> {'directory'}."done.database.tool_models" ) {
 210     $this -> register_tm_relation( model_ids       => \@model_ids,
 211                                    prepared_models => 0 );
 212     open( DB, ">".$this -> {'directory'}."done.database.tool_models" );
 213     print DB "";
 214     close( DB );
 215   }
 216 }
 217 end new
 218
 219 # }}} new
 220
 221 # {{{ log_object
 222
 223 start log_object
 224 {
 225   open( OLOG, '>',$self -> {'directory'}.'object.txt' );
 226   $Data::Dumper::Maxdepth = 1;
 227   print OLOG Dumper $self;
 228   $Data::Dumper::Maxdepth = 0;
 229   close( OLOG );
 230 }
 231 end log_object
 232
 233 # }}} log_object
 234
 235 # {{{ read_log
 236 start read_log
 237 {
 238   if( -e $self -> {'directory'}.'object.txt' ) {
 239     $found_log = 1;
 240     open( OLOG, '<'.$self -> {'directory'}.'object.txt' );
 241     my @olog = <OLOG>;
 242     my $str = "(";
 243     for ( my $i = 1; $i < $#olog; $i++ ) {
 244       $str = $str.$olog[$i];
 245     }
 246     $str = $str.")";
 247     my %tmp = eval( $str );
 248
 249     if( exists $tmp{'tool_id'} ) {
 250       $self -> {'tool_id'} = $tmp{'tool_id'};
 251       $found_tool_id = 1;
 252     }
 253     close( OLOG );
 254   }
 255 }
 256 end read_log
 257 # }}} read_log
 258
 259 # {{{ register_in_database
 260
 261 start register_in_database
 262   {
 263     if ( $PsN::config -> {'_'} -> {'use_database'} ) {
 264       my @tool_name_full = split( '::', ref $self );
 265       my $tool_name = $tool_name_full[$#tool_name_full];
 266       my ( $date_str, $time_str );
 267       if ( $Config{osname} eq 'MSWin32' ) {
 268         $date_str = `date /T`;
 269         $time_str = ' '.`time /T`;
 270       } else {
 271         # Assuming UNIX
 272         $date_str = `date`;
 273       }
 274       chomp($date_str);
 275       chomp($time_str);
 276       my $date_time = $date_str.$time_str;
 277       # Backslashes messes up the sql syntax
 278       my $dir_str = $self->{'directory'};
 279       $dir_str =~ s/\\/\//g;
 280
 281       my $dbh = DBI -> connect("DBI:mysql:host=".$PsN::config -> {'_'} -> {'database_server'}.
 282                                ";databse=".$PsN::config -> {'_'} -> {'project'},
 283                                $PsN::config -> {'_'} -> {'user'},
 284                                $PsN::config -> {'_'} -> {'password'},
 285                                {'RaiseError' => 1});
 286       my $sth;
 287       if ( defined $self -> {'parent_tool_id'} ) {
 288         #           print "INSERT INTO tool (parent_tool_id,name,date,directory) ".
 289         #             "VALUES (".$self -> {'parent_tool_id'}.", '".
 290         #               "$tool_name', '$date_time', '$dir_str' )\n";
 291         $sth = $dbh -> prepare("INSERT INTO ".$PsN::config -> {'_'} -> {'project'}.
 292                                ".tool (parent_tool_id,name,date,directory) ".
 293                                "VALUES (".$self -> {'parent_tool_id'}.", '".
 294                                "$tool_name', '$date_time', '$dir_str' )");
 295       } else {
 296         $sth = $dbh -> prepare("INSERT INTO ".$PsN::config -> {'_'} -> {'project'}.
 297                                ".tool (name,date,directory) ".
 298                                "VALUES ('$tool_name', '$date_time', '$dir_str' )");
 299       }
 300       $sth -> execute;
 301       $self -> {'tool_id'} = $sth->{'mysql_insertid'};
 302       $sth -> finish;
 303       $dbh -> disconnect;
 304     }
 305   }
 306 end register_in_database
 307
 308 # }}} register_in_database
 309
 310 # {{{ register_tm_relation
 311
 312 start register_tm_relation
 313   if ( $PsN::config -> {'_'} -> {'use_database'} and
 314        defined $self -> {'tool_id'} and $#model_ids >= 0 ) {
 315     my $dbh = DBI -> connect("DBI:mysql:host=".$PsN::config -> {'_'} -> {'database_server'}.
 316                              ";databse=".$PsN::config -> {'_'} -> {'project'},
 317                              $PsN::config -> {'_'} -> {'user'},
 318                              $PsN::config -> {'_'} -> {'password'},
 319                              {'raiseerror' => 1});
 320     my $sth;
 321     my $values;
 322     my $columns = "( tool_id, model_id, prepared_model )";
 323     foreach my $model_id ( @model_ids ) {
 324       if ( defined $model_id ) {
 325         $values = $values."," if ( defined $values );
 326         if( $prepared_models ) {
 327           $values = $values."(".$self -> {'tool_id'}.", $model_id, 1 )";
 328         } else {
 329           $values = $values."(".$self -> {'tool_id'}.", $model_id, 0 )";
 330         }
 331       }
 332     }
 333     $sth = $dbh -> prepare( "INSERT INTO ".$PsN::config -> {'_'} -> {'project'}.
 334                                ".tool_model $columns VALUES $values" );
 335     $sth -> execute;
 336     $sth -> finish if ( defined $sth );
 337     $dbh -> disconnect;
 338   }
 339 end register_tm_relation
 340
 341 # }}} register_tm_relation
 342
 343 # {{{ copy
 344
 345 start copy
 346 #      {
 347         #%{$tool} = %{$self};
 348         #$tool -> {'models'} = undef;
 349         #$tool -> {'tools'} = undef;
 350         #@{$tool -> {'models'}} = ();
 351         #@{$tool -> {'tools'}} = ();
 352         #foreach my $model ( @{$self -> {'models'}} ) {
 353         #  push( @{$tool -> {'models'}}, $model -> copy );
 354         #}
 355         #foreach my $subtool ( @{$self -> {'tools'}} ) {
 356         #  push( @{$tool -> {'tools'}}, $subtool -> copy );
 357         #}
 358         #bless( $tool, ref( $self ) );
 359
 360         # ! NOTE ! This is not a deep copy ! NOTE !
 361         # This function has now been replaced with "copying" the "reference object" in new().
 362
 363 #       my $all_parameters = {};
 364
 365 #       foreach my $valid_p ( keys %{ $self -> {'__valid_parameters'} } ){
 366 #         if( defined $self -> {$valid_p} ) {
 367 #           $all_parameters -> {$valid_p} = $self -> {$valid_p};
 368 #         }
 369 #       }
 370
 371 #       %{$all_parameters} = (%{$all_parameters}, %parameters);
 372
 373 #       use Data::Dumper;
 374 #       $Data::Dumper::Maxdepth = 3;
 375 #       print Dumper( $all_parameters );
 376 #       $Data::Dumper::Maxdepth = 0;
 377
 378 #       my $tool_string = ref $self;
 379
 380 #       $tool = "$tool_string" -> new( %{$all_parameters} );
 381 #      }
 382 end copy
 383
 384 # }}} copy
 385
 386 # {{{ pre_fork_setup
 387
 388 start pre_fork_setup
 389       {
 390         # Runs the pre_fork_setup specific for the subtool
 391         my $sub_pre_fork_setup = $self -> {'subtools'} -> [0];
 392         if ( defined $sub_pre_fork_setup ) {
 393           $sub_pre_fork_setup = $sub_pre_fork_setup.'_pre_fork_setup';
 394           if ( defined( $self -> can( $sub_pre_fork_setup ) ) ) {
 395             $self -> $sub_pre_fork_setup;
 396           }
 397         }
 398       }
 399 end pre_fork_setup
 400
 401 # }}} pre_fork_setup
 402
 403 # {{{ print_results
 404
 405 start print_results
 406 {
 407
 408   # Print results created by 'prepare_results' methods specific to the
 409   # tools. prepare_results and print_results are usually called from
 410   # the tool scripts (e.g. bin/bootstrap)
 411
 412   my $sub_print_results = $self -> {'subtools'} -> [0];
 413
 414   if ( defined $sub_print_results ) {
 415
 416     # Only if we have a subtool, which we allways do, 'modelfit' is as
 417     # usual the inner tool in the basic case.
 418
 419
 420     ### get_dim subroutine recurses through arrays of arrays and
 421     ### returns the number of levels (assumes the same number of
 422     ### levels in alls subarrays).
 423     ###
 424     ### 1st argument is the reference to the toplevel array.
 425     ### 2nd argument is a starting level.
 426     ### 3rd argument is an array giving the size of the arrays at each
 427     ### level (assuming same size arrays at each level)
 428
 429     sub get_dim {
 430       my $arr      = shift;
 431       my $dim      = shift;
 432       my $size_ref = shift;
 433       $dim++;
 434       if ( defined $arr and ref($arr) eq 'ARRAY' ) {
 435         push( @{$size_ref}, scalar @{$arr} );
 436         ( $dim, $size_ref ) = get_dim( $arr->[0], $dim, $size_ref );
 437       }
 438       return ( $dim, $size_ref );
 439     }
 440
 441     ### format_value returns a string for a given number. If the value
 442     ### is not defined it is returned as NaN or NA, depending on the
 443     ### output_style configured. Numbers without decimals get 10
 444     ### digits, Numbers with decimals get 10 digis and 5 decimal
 445     ### values.
 446
 447     sub format_value {
 448       my $val = shift;
 449       if ( not defined $val or $val eq '' ) {
 450         return sprintf("%10s",$PsN::out_miss_data).',';
 451       } else {
 452         $_ = $val;
 453         my $nodot = /.*\..*/ ? 0 : 1;
 454         $_ =~ s/\.//g;
 455         if ( /.*\D+.*/ or $nodot) {
 456           return sprintf("%10s",$val).',';
 457         } else {
 458           return sprintf("%10.5f",$val).',';
 459         }
 460       }
 461     }
 462
 463
 464     ### format_label does the same thing as format value, but does not
 465     ### print out "NA" or "NaN" in case of missing data.
 466
 467     sub format_label {
 468       my $val = shift;
 469       if ( not defined $val or $val eq '' ) {
 470         return ',';
 471       } else {
 472         $_ = $val;
 473         my $nodot = /.*\..*/ ? 0 : 1;
 474         $_ =~ s/\.//g;
 475         if ( /.*\D+.*/ or $nodot) {
 476           return sprintf("%10s",$val).',';
 477         } else {
 478           return sprintf("%10.5f",$val).',';
 479         }
 480       }
 481     }
 482
 483     ### The main part of the method will loop through the 'own'
 484     ### results, each element of the 'own' array is a hash with three
 485     ### keys:
 486     ###
 487     ### 'name' of the result, will be used as header (only if
 488     ### values are defined).
 489     ###
 490     ### 'values' either a single value, a list of values or a table of
 491     ### values.
 492     ###
 493     ### 'lables' either a single value(?), a list of values used as
 494     ### header for the 'values' list or table. It can be a table, Then
 495     ### the first row will be printed before each row in the values
 496     ### table, and the second row will be the header.
 497
 498     debug -> die( message => "No results_file defined" )
 499         unless ( defined $self -> {'results_file'} );
 500
 501     open ( RES, ">".$self -> {'directory'}.$self -> {'results_file'} );
 502
 503     if ( defined $self -> {'results'} ) {
 504       my @all_results = @{$self -> {'results'}};
 505
 506       for ( my $i = 0; $i <= $#all_results; $i++ ) {
 507         if ( defined $all_results[$i]{'own'} ) {
 508           my @my_results = @{$all_results[$i]{'own'}};
 509
 510           for ( my $j = 0; $j <= $#my_results; $j++ ) {
 511             # These size estimates include the problem and sub_problem dimensions:
 512             my ( $ldim, $lsize_ref ) = get_dim( $my_results[$j]{'labels'}, -1, [] );
 513             my ( $vdim, $vsize_ref ) = get_dim( $my_results[$j]{'values'}, -1, [] );
 514             print RES $my_results[$j]{'name'},"\n" if ( $vdim > 1 );
 515
 516             if ( defined $my_results[$j]{'values'} and
 517                  scalar @{$my_results[$j]{'values'}} >= 0 ) {
 518               my @values  = @{$my_results[$j]{'values'}};
 519               my @labels;
 520               if ( defined $my_results[$j]{'labels'} and
 521                    scalar @{$my_results[$j]{'labels'}} >= 0 ) {
 522                 @labels = @{$my_results[$j]{'labels'}};
 523               }
 524
 525               # Print Header Labels
 526               if ( $ldim == 0 ) {
 527                 my $label = \@labels;
 528                 print RES ','.format_label($label),"\n";
 529               } elsif ( $ldim == 2 ) {
 530                 print RES ',';
 531                 for ( my $n = 0; $n < scalar @{$labels[1]}; $n++ ) {
 532                   my $label = $labels[1][$n];
 533                   print RES format_label($label);
 534                 }
 535                 print RES "\n";
 536               }
 537
 538               # Print the values (with labels on each row if ldim == 2:
 539               if ( $vdim == 0 ) {
 540                 print RES ','.format_value(\@values),"\n";
 541               } elsif ( $vdim == 1 ) {
 542                 for ( my $m = 0; $m < scalar @values; $m++ ) {
 543                   my $label = $labels[$m];
 544                   print RES ','.format_label($label);
 545                   my $val = $values[$m];
 546                   print RES ','.format_value($val),"\n";
 547                 }
 548               } elsif ( $vdim == 2 ) {
 549                 for ( my $m = 0; $m < scalar @values; $m++ ) {
 550                   my $label;
 551                   if ( $ldim == 1 ) {
 552                     $label = $labels[$m];
 553                   } elsif ( $ldim == 2 ) {
 554                     $label = $labels[0][$m];
 555                   }
 556                   print RES format_label($label);
 557                   if( defined $values[$m] ){
 558                     for ( my $n = 0; $n < scalar @{$values[$m]}; $n++ ) {
 559                       print RES format_value($values[$m][$n]);
 560                     }
 561                   }
 562                   print RES "\n";
 563                 }
 564               }
 565             }
 566           }
 567         }
 568       }
 569     }
 570     close( RES );
 571   } else {
 572     debug -> warn( level => 2,
 573                    message => "No subtools defined".
 574                    ", using default printing routine" );
 575   }
 576 }
 577 end print_results
 578
 579 # }}} print_results
 580
 581 # {{{ post_fork_analyze
 582
 583 start post_fork_analyze
 584       {
 585         # Runs the post_fork_analyze specific for the subtool
 586         my $sub_post_fork_analyze = $self -> {'subtools'} -> [0];
 587         if ( defined $sub_post_fork_analyze ) {
 588           $sub_post_fork_analyze = $sub_post_fork_analyze.'_post_fork_analyze';
 589           if ( defined( $self -> can( $sub_post_fork_analyze ) ) ) {
 590             $self -> $sub_post_fork_analyze;
 591           }
 592         }
 593         if ( defined $self -> {'results_file'} ) {
 594           #$self -> print_results;
 595         }
 596       }
 597 end post_fork_analyze
 598
 599 # }}} post_fork_analyze
 600
 601 # {{{ setup
 602
 603 start setup
 604
 605 $self -> _prepare_model( model_number => $model_number );
 606
 607 # Run the setup specific for the subtool
 608 my $sub_setup = $self -> {'subtools'} -> [0];
 609 if ( defined $sub_setup ) {
 610   $sub_setup = $sub_setup.'_setup';
 611   $self -> $sub_setup( model_number => $model_number );
 612 }
 613 end setup
 614
 615 # }}} setup
 616
 617 # {{{ _make_dir
 618
 619 start _make_dir
 620        {
 621          mkdir( $self -> {'directory'} ) unless ( -e $self -> {'directory'} );
 622        }
 623 end _make_dir
 624
 625 # }}} _make_dir
 626
 627 # {{{ run
 628
 629 # {{{ documentation
 630
 631 # results structure:
 632
 633 # {results}
 634 #      |
 635 #      |->[0]                                First model
 636 #      |   |
 637 #      |   |->{own}                          The results from this tool on the first model
 638 #      |   |    |
 639 #      |   |    |->[0]
 640 #      |   |    |   |
 641 #      |   |    |   |->{name}                    e.g. 'parameter.estimates'
 642 #      |   |    |   |
 643 #      |   |    |   |->{labels}
 644 #      |   |    |   |     |
 645 #      |   |    |   |     |->[0]...              e.g. ['TH1', 'TH2', 'TH3'] indexed on problem and sub problem
 646 #      |   |    |   |     |->[1]
 647 #      |   |    |   |     |...
 648 #      |   |    |   |     |->[#problems]
 649 #      |   |    |   |
 650 #      |   |    |   |->{values}
 651 #      |   |    |         |
 652 #      |   |    |         |->[0]                 e.g. [0.21, 20.3, 3] indexed as above
 653 #      |   |    |         |->[1]
 654 #      |   |    |         |...
 655 #      |   |    |         |->[#problems]
 656 #      |   |    |
 657 #      |   |    |->[1]
 658 #      |   |    |   |
 659 #      |   |    |   |->{name}                    e.g. 'standard.errors'
 660 #      |   |    |   |->{labels}
 661 #      |   |    |   |->{values}
 662 #      |   |->{subtools}                   The results from the subtools on the first model
 663 #      |           |
 664 #      |           |->[0]                    First sub tool
 665 #      |           |   |
 666 #      |           |   |->[0]                First model of the prepared models sent to the first sub tool
 667 #      |           |   |   |
 668 #      |           |   |   |->{own}          The first sub tools results on the first model
 669 #      |           |   |   |    |
 670 #      |           |   |   |    |->[0]       First result type
 671 #      |           |   |   |    |   |
 672 #      |           |   |   |    |   |->{name}
 673 #      |           |   |   |    |   |->{labels}
 674 #      |           |   |   |    |   |->{values}
 675 #      |           |   |   |    |
 676 #      |           |   |   |    |->[1]       Second result type
 677 #      |           |   |   |    |   |
 678 #      |           |   |   |    |   |->{name}
 679 #      |           |   |   |    |   |->{labels}
 680 #      |           |   |   |    |   |->{values}
 681 #      |           |   |   |->{subtools}   Another tool level
 682 #      |           |   |   |      ...
 683 #      |           |   |->[1]                Second model of the prepared models sent to the first sub tool
 684 #      |           |   |   |
 685 #      |           |   |   |->{own}          The first sub tools results on the second model
 686 #      |           |   |   |    |
 687 #      |           |   |   |    |->[0]       First result type
 688 #      |           |   |   |    |   |
 689 #      |           |   |   |    |   |->{name}
 690 #      |           |   |   |    |   |->{labels}
 691 #      |           |   |   |    |   |->{values}
 692 #      |           |   |   |    |
 693 #      |           |   |   |    |->[1]       Second result type
 694 #      |           |   |   |    |   |
 695 #      |           |   |   |    |   |->{name}
 696 #      |           |   |   |    |   |->{labels}
 697 #      |           |   |   |    |   |->{values}
 698 #      |           |   |   |->{subtools}   Another tool level
 699 #      |           |   |   |      ...
 700 #      |           |   |   |...
 701 #      |           |   |->[#prepared models] Last model of the prepared models sent to the first sub tool
 702 #      |           |   |   |
 703 #      |           |   |   |->{own}          The first sub tools results on the last model
 704 #      |           |   |   |    |
 705 #      |           |   |   |    |->[0]       First result type
 706 #      |           |   |   |    |   |
 707 #      |           |   |   |    |   |->{name}
 708 #      |           |   |   |    |   |->{labels}
 709 #      |           |   |   |    |   |->{values}
 710 #      |           |   |   |    |
 711 #      |           |   |   |    |->[1]       Second result type
 712 #      |           |   |   |    |   |
 713 #      |           |   |   |    |   |->{name}
 714 #      |           |   |   |    |   |->{labels}
 715 #      |           |   |   |    |   |->{values}
 716 #      |           |   |   |->{subtools}   Another tool level
 717 #      |           |   |   |      ...
 718 #      |           |->[1]                    Second sub tool
 719 #      |           |...
 720 #      |           |->[#tools]             Last sub tool
 721 #      |
 722 #      |->[1]                                Second model. All above repeated for this model.
 723 #      |...
 724 #      |->[#models]                          Last model. As above.
 725
 726 # Prepared_models structure:
 727
 728 # {prepared_models}
 729 #      |
 730 #      |->[0]                                First model
 731 #      |   |
 732 #      |   |->{own}                          The prepared models of this tool using the first model as base
 733 #      |   |    |
 734 #      |   |    |->[0]                       First prep model
 735 #      |   |    |->[1]                       Second prep model
 736 #      |   |    |...
 737 #      |   |    |->[#prep_models]            Last prep model
 738 #      |   |
 739 #      |   |->{subtools}                   The prepared models of the subtools on the first model. Only one sub tool per prepared model above.
 740 #      |           |
 741 #      |           |->[0]                    First model of the models (prepared above) sent to the first sub tool
 742 #      |           |   |
 743 #      |           |   |->{own}              The first sub tools prepared models on its first model
 744 #      |           |   |    |
 745 #      |           |   |    |->[0]           First prep model
 746 #      |           |   |    |->[1]           Second prep model
 747 #      |           |   |    |...
 748 #      |           |   |    |->[#prep_models]Last prep model
 749 #      |           |   |
 750 #      |           |   |->{subtools}
 751 #      |           |
 752 #      |           |->[1]                    Second model of the models (prepared above) sent to the first sub tool
 753 #      |           |   |
 754 #      |           |   |->{own}              The first sub tools prepared models on its second model
 755 #      |           |   |    |
 756 #      |           |   |    |->[0]           First prep model
 757 #      |           |   |    |->[1]           Second prep model
 758 #      |           |   |    |...
 759 #      |           |   |    |->[#prep_models]Last prep model
 760 #      |           |   |
 761 #      |           |   |->{subtools}
 762 #      |           |
 763
 764 # }}}
 765
 766 start run
 767     {
 768         my $return_dir = getcwd();
 769         chdir( $self -> {'directory'} );
 770
 771         $self -> pre_fork_setup;
 772
 773         my @models = @{$self -> {'models'}};
 774         # Use the thread number of this tool level:
 775         my $threads = ref( $self -> {'threads'} ) eq 'ARRAY' ?
 776             $self -> {'threads'} -> [0] : $self -> {'threads'};
 777
 778         # No point in using more threads than models
 779         $threads = $#models + 1 if ( $threads > $#models + 1);
 780
 781         # Currently parallel execution is not supported on windows platforms
 782         $threads = 1 if( $Config{osname} eq 'MSWin32' );
 783
 784         # Create new forkmanager
 785         my $pm = ext::Parallel::ForkManager -> new($threads) if ( $threads > 1 );
 786         my $aborting = 0;
 787         $pm -> run_on_finish( sub { my ( $pid, $exit_code, $ident ) = @_;
 788                                     if( $exit_code ){
 789                                       debug -> die( message => "Subtool died, exiting." );
 790                                     }
 791                                   } ) if ( $threads > 1 );
 792
 793         # Store some globals for single-thread mode to make each loop
 794         # over the models see the same (fresh) prepared attributes as
 795         # in the parallel mode.
 796         my @pre_fork_tools;
 797
 798         # THREAD if ( $threads == 1 ) {
 799         # THREAD    if ( defined $self -> {'tools'} ) {
 800         # THREAD        @pre_fork_tools = @{$self -> {'tools'}};
 801         # THREAD    }
 802         # THREAD }
 803
 804         # Loop over the models
 805         for ( my $i = 1; $i <= scalar @models; $i++ ) {
 806             # Spawn new processes
 807             $pm -> start and next if ( $threads > 1 );
 808
 809             # model_number is a member that tells the tool which model
 810             # it is currently working on.
 811             $self -> model_number( $i );
 812
 813             # Reset some globals: (only needed for threads==1)
 814             # THREAD if ( $threads == 1 && defined $self -> {'tools'}) {
 815             # THREAD    @{$self -> {'tools'}} = @pre_fork_tools;
 816             # THREAD }
 817
 818             # Make sure that each process gets a unique random sequence:
 819             random_set_seed_from_phrase(random_uniform_integer(1,0,10000*$i));
 820 #           srand(rand()*10000*$i);
 821
 822             # First, run setup
 823             $self -> setup( model_number => $i );
 824
 825             # Run the subtools
 826             my @tool_results = ();
 827             my @tool_models = ();
 828             if ( defined $self -> {'tools'} ) {
 829                 foreach my $tool (@{$self -> {'tools'}}){
 830                     # There is to date (2004-01-27 no tool that creates more than one internal
 831                     # tool. Hence this is a loop of one cycle. But to be general, again...
 832                     # Run the tool:
 833                     my( $returns, $prep_models ) = $tool -> run;
 834                     # push the sub tool's return values
 835                     push ( @tool_results, $returns );
 836                     if ( defined $prep_models ) {
 837                         push ( @tool_models, $prep_models );
 838                     } else {
 839                       'debug' -> warn(level => 1,
 840                                       message => "inside " . ref($self) . " but no prep_models defined from $tool $i");
 841                     }
 842                     $self -> post_subtool_analyze;
 843                 }
 844
 845             } else {
 846                 debug -> warn( level   => 2,
 847                                message => "No tool object to run from tool object." );
 848             }
 849
 850             $self -> {'results'}[$i-1]{'subtools'}= \@tool_results;
 851             $self -> {'prepared_models'}[$i-1]{'subtools'} = \@tool_models;
 852
 853             # Analyze the results
 854             $self -> analyze( model_number => $i );
 855
 856             Storable::store( $self -> {'prepared_models'},
 857                              $self -> {'directory'}."/m$i/prepared_models.log" );
 858             if ( $threads > 1 ) {
 859                 Storable::store( $self -> {'results'},
 860                                  $self -> {'directory'}."/m$i/results.log" );
 861                   # Maybe redundant to transfer back both prepared_models as well as tools
 862
 863                   # Actually, by principle everything interesting for
 864                   # a parent should be placed in "results" or possibly
 865                   # "prepared_models".
 866
 867                   #Storable::store( $self -> {'tools'},
 868                         #          $self -> {'directory'}."/m$i/tools.log" );
 869                 }
 870             $pm -> finish if ( $threads > 1 );
 871         }
 872         $pm -> wait_all_children if ( $threads > 1 );
 873
 874         for( my $i = 1; $i <= scalar @{$self -> {'models'}}; $i++ ) {
 875           my @prepared_models = @{Storable::retrieve( $self -> {'directory'}.
 876                                                       "/m$i/prepared_models.log" )};
 877           unlink( $self -> {'directory'} . "/m$i/prepared_models.log" );
 878           $self->{'prepared_models'}[$i-1] = $prepared_models[$i-1];
 879         }
 880
 881         if ( $threads > 1 ) {
 882             for( my $i = 1; $i <= scalar @{$self -> {'models'}}; $i++ ) {
 883                 my @model_results = @{Storable::retrieve( $self -> {'directory'}.
 884                                                               "/m$i/results.log" )};
 885 # It is important to keep the number of dimensions: push the first value, not the
 886 # whole array!
 887                 $self->{'results'}[$i-1] = $model_results[$i-1];
 888
 889                 # Read comment aboud tools.log near storable above.
 890
 891                 #push( @{$self -> {'tools'}},
 892                 #      Storable::retrieve( $self -> {'directory'}.
 893                 #                         "/m$i/tools.log" ) );
 894             }
 895           }
 896
 897
 898         # Perform analyses that need to be done after all models have
 899         # been run and processed. Also write a result file if one is
 900         # defined.
 901         $self -> post_fork_analyze;
 902
 903         chdir($return_dir);
 904         if( $self -> {'clean'} >= 3 and not $self -> {'top_tool'} ){
 905
 906           my $top_dir = $self -> {'directory'};
 907           foreach my $dir ( <$top_dir/m*> ){
 908             if( $dir =~ /m[0123456789]+/ ){
 909               unlink( <$dir/*> );
 910               rmdir( $dir );
 911             }
 912           }
 913
 914           my $dir = $self -> {'directory'};
 915           unlink( <$dir/*> );
 916           rmdir( $dir );
 917         }
 918 #       @results     = @{$self -> {'results'}};
 919 #       @prepared_models = @{$self -> {'prepared_models'}};
 920       }
 921 end run
 922
 923 # }}} run
 924
 925 # {{{ _prepare_model
 926
 927 start _prepare_model
 928       {
 929
 930           my ($newdir, $newfile) = OSspecific::absolute_path( $self -> {'directory'} .  '/m'.$model_number, '' );
 931           debug -> warn( level   => 2,
 932                          message => "Making directory\t\t" . $newdir );
 933           mkdir( $newdir );
 934           if ( defined $self -> models() ) {
 935             my @models = @{$self -> models()};
 936             if ( defined $models[$model_number - 1] ) {
 937               my $model = $models[$model_number - 1];
 938               # copy the msfi files
 939               my @new_names;
 940               if( defined $model -> msfi_names() ){
 941                 foreach my $msfi_files( @{$model -> msfi_names()} ){
 942                   foreach my $msfi_file( @{$msfi_files} ){
 943                     if ( defined $msfi_file ) {
 944                       my ( $dir, $filename ) = OSspecific::absolute_path($model -> directory,
 945                                                                          $msfi_file );
 946                       cp( $dir.$filename, $newdir.$filename );
 947                       push( @new_names, $filename );
 948                     } else {
 949                       push( @new_names, undef );
 950                     }
 951                   }
 952                 }
 953                 $model -> msfi_names( new_names => \@new_names );
 954               }
 955             }
 956           }
 957       }
 958 end _prepare_model
 959
 960 # }}} _prepare_model
 961
 962 # {{{ analyze
 963
 964 start analyze
 965       {
 966         $self -> {'raw_results'}[$model_number-1] =
 967           $self -> {'tools'} -> [0] -> raw_results if( defined $self -> {'tools'} -> [0] );
 968         my $sub_analyze = $self -> {'subtools'} -> [0];
 969         if ( defined $sub_analyze ) {
 970           $sub_analyze = $sub_analyze.'_analyze';
 971           if( defined $self -> can( $sub_analyze ) ){
 972             $self -> $sub_analyze( model_number => $model_number );
 973           }
 974         }
 975       }
 976 end analyze
 977
 978 # }}} analyze
 979
 980 # {{{ _modelfit_raw_results_callback
 981
 982 start _modelfit_raw_results_callback
 983       {
 984         my ($dir,$file) =
 985           OSspecific::absolute_path( $self -> {'directory'},
 986                                      $self -> {'raw_results_file'}[$model_number-1] );
 987         my ($dir,$nonp_file) =
 988           OSspecific::absolute_path( $self -> {'directory'},
 989                                      $self -> {'raw_nonp_file'}[$model_number-1] );
 990         $subroutine = sub {
 991           my $modelfit = shift;
 992           $modelfit -> raw_results_file( $dir.$file );
 993           $modelfit -> raw_nonp_file( $dir.$nonp_file );
 994         };
 995         return $subroutine;
 996       }
 997 end _modelfit_raw_results_callback
 998
 999 # }}} _modelfit_raw_results_callback
1000
1001 # {{{ read_raw_results
1002 start read_raw_results
1003       {
1004         undef $self -> {'raw_results_header'};
1005         for ( my $i = 1; $i <= scalar @{$self->{'models'}}; $i++ ) { # All models
1006           if ( -e $self -> {'directory'}.'raw_results'.$i.'.csv' ) {
1007             open( RRES, $self -> {'directory'}.'raw_results'.$i.'.csv' );
1008             my @file = <RRES>;
1009             close( RRES );
1010             map { chomp; my @tmp = split(',',$_); $_ = \@tmp } @file ;
1011             $self -> {'raw_results_header'} -> [$i-1] = shift @file;
1012             $self -> {'raw_results'} -> [$i-1] = \@file;
1013           }
1014           if ( -e $self -> {'directory'}.'raw_nonp_results'.$i.'.csv' ) {
1015             open( RRES, $self -> {'directory'}.'raw_nonp_results'.$i.'.csv' );
1016             my @file = <RRES>;
1017             close( RRES );
1018             map { chomp; my @tmp = split(',',$_); $_ = \@tmp } @file ;
1019             $self -> {'raw_nonp_results'} -> [$i-1] = \@file;
1020           }
1021         }
1022       }
1023 end read_raw_results
1024 # }}} read_raw_results
1025
1026 # {{{ create_raw_results_rows
1027 start create_raw_results_rows
1028   {
1029
1030     unless( $model -> outputs -> [0] -> parsed ){
1031       $model -> outputs -> [0] -> abort_on_fail(0);
1032       $model -> outputs -> [0] -> _read_problems;
1033     }
1034
1035     if( $model -> outputs -> [0] -> parsed_successfully ){
1036       my @probs = @{$model -> outputs -> [0] -> problem_structure};
1037       my $np = scalar @probs; # #probs
1038       my $model_row = 0;
1039       # ------------  Push model, problem and sub-problem numbers  --------------
1040
1041       for( my $j = 0; $j < $np; $j++ ) {
1042         my $ns = $probs[$j]; # #subprobs
1043         for( my $k = 0; $k < $ns; $k++ ) {
1044           my $row = $model_row++;
1045           push( @{$return_rows[$row]}, ($model_number,($j+1),($k+1)) );
1046         }
1047       }
1048
1049       # ---------------------  Loop all result categories  ----------------------
1050
1051       foreach my $category ( @{$self -> {'raw_results_header'}},'npomega' ){
1052         next if( $category eq 'model' or $category eq 'problem' or $category eq 'subproblem' );
1053         my ( $accessor, $res );
1054
1055         # {{{ Get the values for the category
1056
1057         if ( $category eq 'theta' or $category eq 'omega' or $category eq 'sigma' or
1058              $category eq 'setheta' or $category eq 'seomega' or $category eq 'sesigma' or
1059              $category eq 'npomega' or $category eq 'eigen' ) {
1060           $accessor = $category.'s';
1061           $res = $model -> {'outputs'} -> [0] -> $accessor;
1062         } elsif ( $category eq 'shrinkage_etas' ) {
1063           # Shrinkage does not work for subproblems right now.
1064           $res = $model -> eta_shrinkage;
1065         } elsif ( $category eq 'shrinkage_wres' ) {
1066           # Shrinkage does not work for subproblems right now.
1067           # get ofv just to get the prob-subp structure
1068           $res = $model -> wres_shrinkage;
1069         } else {
1070           $accessor = $category;
1071           $res = $model -> {'outputs'} -> [0] -> $accessor;
1072         }
1073
1074         # {{{ Create entry in raw_line_structure
1075         if( defined $res and ref $res eq 'ARRAY' and $category ne 'npomega' ){
1076           my $prob_num = 0;
1077           foreach my $prob ( @{$res} ){
1078             if( defined $prob and ref $prob eq 'ARRAY' ){
1079               if( defined $prob -> [0] and ref $prob -> [0] eq 'ARRAY' and
1080                   defined $return_rows[$prob_num] ){
1081
1082                 # The last check in the IF above could be put there to
1083                 # avoid a bug. If "output::problem_structure" is
1084                 # correct and output::accessor is correct,
1085                 # $return_rows[$prob_num] should allways be
1086                 # defined. TODO
1087
1088                 my $tmp = scalar @{$return_rows[$prob_num]} . ",". scalar @{$prob -> [0]};
1089                 $raw_line_structure -> {$model_number} -> { $category } = $tmp;
1090
1091               } elsif( defined $prob -> [0] and defined $return_rows[$prob_num]) {
1092                 my $tmp = scalar @{$return_rows[$prob_num]} . ",1";
1093                 $raw_line_structure -> {$model_number} -> { $category } = $tmp;
1094               }
1095             }
1096             $prob_num++;
1097           }
1098         }
1099
1100         # }}}
1101
1102         # }}} Get the values for the category
1103         my $return_array_ref;
1104         if( $category eq 'npomega' ){
1105           $return_array_ref = \@nonp_return_rows;
1106           next;
1107         } else {
1108           $return_array_ref = \@return_rows;
1109         }
1110
1111         my $model_row = 0; # Need to mask previous definition of model_row
1112
1113         if( defined $res ) {
1114           for( my $j = 0; $j < $np; $j++ ) {
1115             my $ns = $probs[$j]; # #subprobs
1116             if( defined $res -> [$j] ) {
1117               for( my $k = 0; $k < $ns; $k++ ) {
1118                 my $row = $model_row++;
1119                 if( ref $res -> [$j] eq 'ARRAY' ){
1120                   if( defined $res -> [$j][$k] ) {
1121                     if ( ref $res -> [$j][$k] eq 'ARRAY' ) {
1122                       push( @{$return_array_ref -> [$row]}, @{$res -> [$j][$k]} );
1123                       push( @{$return_array_ref -> [$row]},
1124                             (undef) x ($max_hash -> {$category} - scalar @{$res -> [$j][$k]})  );
1125                     } else {
1126                       push( @{$return_array_ref -> [$row]}, $res -> [$j][$k] );
1127                     }
1128                   } else {
1129                     push( @{$return_array_ref -> [$row]},
1130                           (undef) x $max_hash -> {$category}  );
1131                   }
1132                 } else {
1133                   push( @{$return_array_ref -> [$row]},
1134                         $res -> [$j] );
1135                 }
1136               }
1137             } else {
1138
1139               # {{{ Push undefs for missing subprobs
1140
1141               for( my $k = 0; $k < $ns; $k++ ) {
1142                 my $row = $model_row++;
1143                 push( @{$return_array_ref -> [$row]},
1144                       (undef) x $max_hash -> {$category}  );
1145               }
1146
1147               # }}} Push undefs for missing subprobs
1148
1149             }
1150
1151           }
1152         } else {
1153
1154           # {{{ Push undefs for missing probs/subprobs
1155
1156           for( my $j = 0; $j < $np; $j++ ) {
1157             my $ns = $probs[$j]; # #subprobs
1158             for( my $k = 0; $k < $ns; $k++ ) {
1159               my $row = $model_row++;
1160               push( @{$return_array_ref -> [$row]},
1161                     (undef) x $max_hash -> {$category}  );
1162             }
1163           }
1164
1165           # }}} Push undefs for missing probs/subprobs
1166
1167         }
1168
1169       }
1170
1171       $raw_line_structure -> {$model_number} -> {'line_numbers'} = scalar @return_rows;
1172
1173     } else {
1174       # Output not parsed successfully.
1175       $return_rows[0] = [ $model_number.
1176                           ",run failed - Could not parse the output file: ".
1177                           $model -> {'outputs'} -> [0] -> filename ];
1178     }
1179   }
1180 end create_raw_results_rows
1181 # }}}
1182
1183 # {{{ post_subtool_analyze
1184
1185 start post_subtool_analyze
1186     {
1187         my $sub_analyze = $self -> {'subtools'} -> [0];
1188         if ( defined $sub_analyze ) {
1189             $sub_analyze = $sub_analyze.'_post_subtool_analyze';
1190             if( defined $self -> can( $sub_analyze ) ){
1191                 $self -> $sub_analyze( model_number => $model_number );
1192             }
1193         }
1194     }
1195 end post_subtool_analyze
1196
1197 # }}} analyze
1198
1199 # {{{ harvest_output
1200
1201 start harvest_output
1202     {
1203
1204       # harvest_output is a complement to AUTOLOAD below. AUTOLOAD is
1205       # currently used to find the AUTOLOAD:ed accessor in any
1206       # existing subtool, model, data or outputobject. It is
1207       # inefficient in that it will have to be called for once for
1208       # each accessor. harvest_output will take a list of accessors
1209       # that it will search for in each object, saving time and
1210       # foremost; memory. Also it will take arguments such as
1211       # "search_models", "search_subtools" that will make things more
1212       # efficient if you know where to search.
1213
1214       unless( $search_models + $search_output + $search_data <= 1 ){
1215         'debug' -> die( message => "This is a PsN bug: Only one of the 'search_' options can and must be specified.".
1216                         "\t search_models: $search_models\n".
1217                         "\t search_data: $search_data\n".
1218                         "\t search_output: $search_output");
1219       }
1220
1221       if ( $search_subtools ) {
1222         'debug' -> warn( level => 1,
1223                          message => "\n\nSearching subtools, which is a very untested functionality!!\n\n" );
1224
1225 #       if ( defined $self -> {'tools'} ) {
1226 #         my @tools = @{$self -> {'tools'}};
1227 #         foreach my $tool_ref ( @tools ) {
1228 #           foreach my $tool ( @{$tool_ref} ) {
1229 #             if ( $tool -> can( $accessor ) ) {
1230 #               push( @result, $tool -> $accessor( %accessor_parameters ) );
1231 #             } else {
1232 #               'debug' -> die(message => "Accessor $accessor is not available in the tool " . ref($tool) );
1233 #             }
1234 #           }
1235 #         }
1236 #       } else {
1237 #         'debug' -> warn( level => 1,
1238 #                          message => "Supposed to be run by the sub tools but no sub tools were defined" );
1239 #       }
1240
1241       } else {
1242
1243         sub models_traverse2 {
1244           my %parameters = @_;
1245           my @models = $parameters{'models'} ? @{$parameters{'models'}} : ();
1246           my $search_models = $parameters{'search_models'};
1247           my $search_output = $parameters{'search_output'};
1248           my $search_data   = $parameters{'search_data'};
1249           my $accessor_parameters = $parameters{'accessor_parameters'};
1250           my $accessors = $parameters{'accessors'};
1251           my %results;
1252
1253           for( my $i = 0; $i < scalar (@models); $i++ ){
1254
1255             foreach my $model ( @{$models[$i]{'own'}} ) {
1256
1257               foreach my $accessor( @{$accessors} ) {
1258
1259                 if( $search_models and $model -> can( $accessor ) ) {
1260                   push( @{$results{$accessor}[$i]{'own'}}, $model -> $accessor( %{$accessor_parameters} ) );
1261
1262                 } elsif( $search_data and $model -> datas -> [0] -> can( $accessor ) ) {
1263                   push( @{$results{$accessor}[$i]{'own'}}, $model -> datas -> [0] -> $accessor( %{$accessor_parameters} ) );
1264
1265                 } elsif( $search_output and $model -> outputs -> [0] -> can( $accessor ) ) {
1266                   push( @{$results{$accessor}[$i]{'own'}}, $model -> outputs -> [0] -> $accessor( %{$accessor_parameters} ) );
1267
1268                 } else {
1269                   'debug' -> die( message => "Neither model, data, output have a method for $accessor" );
1270                 }
1271
1272                 if ( defined $models[$i]{'subtools'} ) {
1273                   push( @{$results{$accessor}[$i]{'subtools'}}, models_traverse2( models => $models[$i]{'subtools'} ) );
1274                 }
1275               }
1276
1277               if( $search_data ){
1278                 $model -> datas -> [0] -> flush();
1279               }
1280               if( $search_output ){
1281                 $model -> outputs -> [0] -> flush();
1282               }
1283             }
1284
1285           }
1286           return \%results;
1287         }
1288       }
1289
1290       my @models;
1291
1292       if ( $search_original_models ) {
1293         @models = @{$self -> {'models'}};
1294       } elsif ( defined $self -> {'prepared_models'} ) {
1295         @models = @{$self -> {'prepared_models'}};
1296       } else {
1297         'debug' -> warn( level => 2,
1298                          message => "Trying @accessors, but no prepared models available" );
1299         return {};
1300       }
1301
1302       %result = %{models_traverse2( models => \@models,
1303                                    search_models => $search_models,
1304                                    search_output => $search_output,
1305                                    search_data => $search_data,
1306                                    accessor_parameters => \%accessor_parameters,
1307                                    accessors => \@accessors )};
1308
1309     }
1310 end harvest_output
1311
1312 # }}}
1313
1314 # {{{ AUTOLOAD
1315
1316 start AUTOLOAD
1317       {
1318         debug -> warn( level => 2,
1319                        message => "Caught method $AUTOLOAD" );
1320         debug -> warn( level => 2,
1321                        message => "arguments: @_" );;
1322         my %parm = @_;
1323         my $original_models = $parm{'original_models'};
1324         delete( $parm{'original_models'} );
1325         my $class = $parm{'class'};
1326         $AUTOLOAD =~ s/.*://;
1327         return if $AUTOLOAD eq 'DESTROY';
1328
1329 # TODO: Kolla att orginalmodellen körs med submetod i run!!!!! kolla också var resultaten
1330 # läggs!!!
1331
1332         if ( $class =~ /tool::/ ) {
1333           delete( $parm{'mod_array'} );
1334           delete( $parm{'original_models'} );
1335           delete( $parm{'class'} );
1336           @_ = %parm;
1337           if ( defined $self -> {'tools'} ) {
1338             my @tools = @{$self -> {'tools'}};
1339             my $accessor = $AUTOLOAD;
1340             foreach my $tool_ref ( @tools ) {
1341               foreach my $tool ( @{$tool_ref} ) {
1342                 if ( $tool -> can( $accessor ) ) {
1343                   push( @result, $tool -> $accessor( @_ ) );
1344                 } else {
1345                   'debug' -> die(message => "Accessor $accessor is not available in the tool " . ref($tool) );
1346                 }
1347               }
1348             }
1349           } else {
1350             print "AUTOLOAD in ",ref($self)," caught tool $AUTOLOAD. It was ",
1351               "supposed to be run by the sub tools but no sub tools were defined\n";
1352           }
1353         } else {
1354           my @models;
1355           my @prep_models;
1356           if ( $original_models ) {
1357             @models = @{$self -> {'models'}};
1358           } elsif ( defined $self -> {'prepared_models'} ) {
1359             'debug' -> warn(level => 1,
1360                             message => "Using prepared models" );
1361             @prep_models = @{$self -> {'prepared_models'}};
1362           } else {
1363             print "WARNING: tool -> AUTOLOAD: Trying $AUTOLOAD, but no prepared models available\n";
1364           }
1365
1366           sub models_traverse {
1367             my %parm  = @_;
1368             my $mod_array_ref = $parm{'mod_array'};
1369             my $class     = $parm{'class'};
1370             delete( $parm{'mod_array'} );
1371             delete( $parm{'class'} );
1372             @_ = %parm;
1373             my @mod_array;
1374             @mod_array = defined $mod_array_ref ? @{$mod_array_ref} : ();
1375             my @inner_result = ();
1376             #             my $i = 0;
1377             for ( my $i = 0; $i <= $#mod_array; $i++ ) {
1378               foreach my $model ( @{$mod_array[$i]{'own'}} ) {
1379                 unless ( defined $class ) {
1380                   my $mod_can = defined $model -> can( $AUTOLOAD ) ? 1 : 0;
1381                   my $out_can = (defined $model -> outputs and
1382                                  defined $model -> outputs -> [0] and
1383                                  defined $model -> outputs -> [0] -> can($AUTOLOAD))
1384                     ? 1 : 0;
1385                   my $dat_can = (defined $model -> datas and
1386                                  defined $model -> datas -> [0] and
1387                                  defined $model -> datas -> [0] -> can($AUTOLOAD))
1388                     ? 1 : 0;
1389                   if ( ($mod_can + $out_can + $dat_can) > 1 ) {
1390                     my $classes;
1391                     $classes = 'model ' if $mod_can;
1392                     $classes = $classes.'output ' if $out_can;
1393                     $classes = $classes.'data ' if $dat_can;
1394                     'debug' -> die( message => "Accessor $AUTOLOAD available in multiple classes: $classes" );
1395                   }
1396                   if ( $mod_can + $out_can + $dat_can == 0 ) {
1397                     'debug' -> die( message => "Accessor $AUTOLOAD is not available in any of the model, ".
1398                                     "output or data classes OR no output or data object available".
1399                                     " through this model" );
1400                   }
1401                   if ( $mod_can ) {
1402                     push( @{$inner_result[$i]{'own'}}, $model -> $AUTOLOAD( @_ ) );
1403                   } elsif ( $out_can ) {
1404                     push( @{$inner_result[$i]{'own'}}, $model -> outputs -> [0] -> $AUTOLOAD( @_ ) );
1405                   } elsif ( $dat_can ) {
1406                     push( @{$inner_result[$i]{'own'}}, $model -> datas -> [0] -> $AUTOLOAD( @_ ) );
1407                   }
1408                 } else {
1409                   if ( $class eq 'model' ) {
1410                     push( @{$inner_result[$i]{'own'}}, $model -> $AUTOLOAD( @_ ) );
1411                   } else {
1412                     my $class_accessor = $class.'s';
1413                     push( @{$inner_result[$i]{'own'}}, $model -> $class_accessor -> [0] -> $AUTOLOAD( @_ ) );
1414                   }
1415                 }
1416               }
1417               #               $i++;
1418               if ( defined $mod_array[$i]{'subtools'} ) {
1419                 push( @{$inner_result[$i]{'subtools'}},
1420                       models_traverse( mod_array => $mod_array[$i]{'subtools'},
1421                                        class     => $class,
1422                                        %parm ) );
1423               }
1424             }
1425             return \@inner_result;
1426           }
1427           if ( $original_models ) {
1428             debug -> warn( level => 2,
1429                            message => "Traversing ".scalar $models[0]{'own'}." model(s)" );
1430             @result = @{models_traverse( mod_array => \@models,
1431                                          %parm )};
1432           } else {
1433             @result = @{models_traverse( mod_array => \@prep_models,
1434                                          %parm )};
1435           }
1436         }
1437       }
1438 end AUTOLOAD
1439
1440 # }}} AUTOLOAD