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