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<rm_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<rm_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<rm_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         debug -> die( message => "No model specified!" )
 158             unless ( defined $this -> {'models'} and scalar @{$this -> {'models'}} > 0 );
 159         foreach my $mod ( @{$this -> {'models'}} ) {
 160           debug -> die( message => "Supplied argument model is not defined" )
 161               unless defined $mod;
 162         }
 163         # 1. Make sure that the filenames are absolute
 164         foreach my $model ( @{$this -> {'models'}} ) {
 165             my ($directory, $filename) = OSspecific::absolute_path( $model -> directory, $model -> filename );
 166             $model -> filename( $filename );
 167             $model -> directory( $directory );
 168           if ( defined $model -> outputs ) {
 169             my @outputs = @{$model -> outputs};
 170             foreach my $output ( @outputs ) {
 171                 my ($directory, $filename) = OSspecific::absolute_path( $outputs[0] -> directory, $outputs[0] -> filename );
 172                 $output -> filename( $filename );
 173                 $output -> directory( $directory );
 174             }
 175           }
 176           if ( defined $model -> datas ) {
 177             my @datas = @{$model -> datas};
 178             foreach my $data ( @datas ) {
 179                 my ($directory, $filename) = OSspecific::absolute_path( $datas[0] -> directory, $datas[0] -> filename );
 180                 $data -> filename( $filename );
 181                 $data -> directory( $directory );
 182             }
 183           }
 184         }
 185         # Create my temporary directory
 186         $this -> _make_dir;
 187
 188         if ( $PsN::config -> {'_'} -> {'use_database'} ) {
 189           my ( $date_cmd, $time_cmd );
 190           if( $Config{osname} eq 'MSWin32' ){
 191             $date_cmd = 'date /T';
 192             $time_cmd = 'time /T';
 193           } else {
 194             # Assuming UNIX
 195             $date_cmd = 'date';
 196             $time_cmd = 'time';
 197           }
 198
 199           my $date_str = `$date_cmd`;
 200           my $time_str = `$time_cmd`;
 201           chomp($date_str);
 202           chomp($time_str);
 203           my $date_time = "$date_str $time_str";
 204           # Backslashes messes up the sql syntax
 205           my $dir_str = $this->{'directory'};
 206           $dir_str =~ s/\\/\//g;
 207
 208           my $dbh = DBI -> connect("DBI:mysql:host=localhost;databse=psn",
 209                                    "psn", "psn_test",
 210                                    {'RaiseError' => 1});
 211           my $sth;
 212           if ( defined $this -> {'parent_tool_id'} ) {
 213 #           print "INSERT INTO psn.tool (parent_tool_id,name,date,directory) ".
 214 #             "VALUES (".$this -> {'parent_tool_id'}.", '".
 215 #               "$tool_name', '$date_time', '$dir_str' )\n";
 216             $sth = $dbh -> prepare("INSERT INTO psn.tool (parent_tool_id,name,date,directory) ".
 217                                    "VALUES (".$this -> {'parent_tool_id'}.", '".
 218                                    "$tool_name', '$date_time', '$dir_str' )");
 219           } else {
 220             $sth = $dbh -> prepare("INSERT INTO psn.tool (name,date,directory) ".
 221                                    "VALUES ('$tool_name', '$date_time', '$dir_str' )");
 222           }
 223           $sth -> execute;
 224           $this -> {'tool_id'} = $sth->{'mysql_insertid'};
 225
 226           foreach my $model ( @{$this -> {'models'}} ) {
 227             my $sth = $dbh -> prepare("INSERT INTO psn.tool_model (tool_id,model_id) ".
 228                                       "VALUES ('".$this -> {'tool_id'}."', ".
 229                                       $model -> model_id." )");
 230             $sth -> execute;
 231           }
 232
 233           $sth -> finish;
 234
 235           $dbh -> disconnect;
 236         }
 237       }
 238 end new
 239
 240 # }}} new
 241
 242 # {{{ copy
 243
 244 start copy
 245 #      {
 246         #%{$tool} = %{$self};
 247         #$tool -> {'models'} = undef;
 248         #$tool -> {'tools'} = undef;
 249         #@{$tool -> {'models'}} = ();
 250         #@{$tool -> {'tools'}} = ();
 251         #foreach my $model ( @{$self -> {'models'}} ) {
 252         #  push( @{$tool -> {'models'}}, $model -> copy );
 253         #}
 254         #foreach my $subtool ( @{$self -> {'tools'}} ) {
 255         #  push( @{$tool -> {'tools'}}, $subtool -> copy );
 256         #}
 257         #bless( $tool, ref( $self ) );
 258
 259         # ! NOTE ! This is not a deep copy ! NOTE !
 260         # This function has now been replaced with "copying" the "reference object" in new().
 261
 262 #       my $all_parameters = {};
 263
 264 #       foreach my $valid_p ( keys %{ $self -> {'__valid_parameters'} } ){
 265 #         if( defined $self -> {$valid_p} ) {
 266 #           $all_parameters -> {$valid_p} = $self -> {$valid_p};
 267 #         }
 268 #       }
 269
 270 #       %{$all_parameters} = (%{$all_parameters}, %parameters);
 271
 272 #       use Data::Dumper;
 273 #       $Data::Dumper::Maxdepth = 3;
 274 #       print Dumper( $all_parameters );
 275 #       $Data::Dumper::Maxdepth = 0;
 276
 277 #       my $tool_string = ref $self;
 278
 279 #       $tool = "$tool_string" -> new( %{$all_parameters} );
 280 #      }
 281 end copy
 282
 283 # }}} copy
 284
 285 # {{{ pre_fork_setup
 286
 287 start pre_fork_setup
 288       {
 289         # Runs the pre_fork_setup specific for the subtool
 290         # Create a template for the results:
 291
 292 #       my %results;
 293 #       $results{'own'} = [];
 294 #       $results{'subtools'} = [];
 295 #       $self -> {'results'} = \%results;
 296
 297         # Run the pre_fork_setup specific for the subtool
 298         my $sub_pre_fork_setup = $self -> {'subtools'} -> [0];
 299         if ( defined $sub_pre_fork_setup ) {
 300           $sub_pre_fork_setup = $sub_pre_fork_setup.'_pre_fork_setup';
 301           if ( defined( $self -> can( $sub_pre_fork_setup ) ) ) {
 302             $self -> $sub_pre_fork_setup;
 303           }
 304         }
 305       }
 306 end pre_fork_setup
 307
 308 # }}} pre_fork_setup
 309
 310 # {{{ print_results
 311
 312 start print_results
 313       {
 314         # Run the print_results specific for the subtool
 315         my $sub_print_results = $self -> {'subtools'} -> [0];
 316         if ( defined $sub_print_results ) {
 317           # Bortkommenterat just nu (2004-10-10) skall användas senare
 318 #         $sub_print_results = $sub_print_results.'_results';
 319 #         if ( defined( $self -> can( $sub_print_results ) ) ) {
 320 #           $self -> $sub_print_results( @_ );
 321 #         } else {
 322             sub get_dim {
 323               my $arr      = shift;
 324               my $dim      = shift;
 325               my $size_ref = shift;
 326               $dim++;
 327               if ( defined $arr and ref($arr) eq 'ARRAY' ) {
 328                 push( @{$size_ref}, scalar @{$arr} );
 329                 ( $dim, $size_ref ) = get_dim( $arr->[0], $dim, $size_ref );
 330               }
 331               return ( $dim, $size_ref );
 332             }
 333             sub format_value {
 334               my $val = shift;
 335               if ( not defined $val or $val eq '' ) {
 336                 return sprintf("%10s",$PsN::output_style).',';
 337               } else {
 338                 $_ = $val;
 339                 my $nodot = /.*\..*/ ? 0 : 1;
 340                 $_ =~ s/\.//g;
 341                 if ( /.*\D+.*/ or $nodot) {
 342                   return sprintf("%10s",$val).',';
 343                 } else {
 344                   return sprintf("%10.5f",$val).',';
 345                 }
 346               }
 347             }
 348             debug -> die( message => "No results_file defined" )
 349                 unless ( defined $self -> {'results_file'} );
 350             open ( RES, ">".$self -> {'directory'}.'/'.$self -> {'results_file'} );
 351             if ( defined $self -> {'results'} ) {
 352               my @all_results = @{$self -> {'results'}};
 353               for ( my $i = 0; $i <= $#all_results; $i++ ) {
 354                 if ( defined $all_results[$i]{'own'} ) {
 355                   my @my_results = @{$all_results[$i]{'own'}};
 356                   for ( my $j = 0; $j <= $#my_results; $j++ ) {
 357                     # These size estimates include the problem and sub_problem dimensions:
 358                     my ( $ldim, $lsize_ref ) = get_dim( $my_results[$j]{'labels'}, -1, [] );
 359                     my ( $vdim, $vsize_ref ) = get_dim( $my_results[$j]{'values'}, -1, [] );
 360 #                   print $my_results[$j]{'name'}," $ldim (",join(' ',@{$lsize_ref}),") ",
 361 #                     "$vdim (",join(' ',@{$vsize_ref}),")\n";
 362                     print RES $my_results[$j]{'name'},"\n" if ( $vdim > 1 );
 363                     # Loop the problems:
 364                     if ( defined $my_results[$j]{'values'} and
 365                          scalar @{$my_results[$j]{'values'}} >= 0 ) {
 366                       my @probs  = @{$my_results[$j]{'values'}};
 367                       my @labels;
 368                       if ( defined $my_results[$j]{'labels'} and
 369                            scalar @{$my_results[$j]{'labels'}} >= 0 ) {
 370                         @labels = @{$my_results[$j]{'labels'}};
 371                       }
 372                       for ( my $prob = 0; $prob <= $#probs; $prob++ ) {
 373                         print RES "PROBLEM ",$prob+1,"\n" unless ( $#probs == 0 );
 374                         # Loop the sub_problems
 375                         for ( my $subp = 0; $subp < scalar @{$probs[$prob]}; $subp++ ) {
 376                           print RES "SUBPROBLEM ",$subp+1,"\n"
 377                             unless ( scalar @{$probs[$prob]} == 1 );
 378                           # Print Header Labels
 379                           if ( $ldim == 2 ) {
 380                             my $label = $labels[$prob][$subp];
 381                             print RES ','.format_value($label),"\n";
 382 #                             if ( defined $label and $label ne '' );
 383                           } elsif ( $ldim == 4 ) {
 384                             print RES ',';
 385                             for ( my $n = 0; $n < scalar @{$labels[$prob][$subp][1]}; $n++ ) {
 386                               my $label = $labels[$prob][$subp][1][$n];
 387                               print RES format_value($label);
 388 #                               if ( defined $label and $label ne '' );
 389                             }
 390                             print RES "\n" if ( scalar @{$labels[$prob][$subp][1]} );
 391                           }
 392                           # Print the values:
 393                           if ( $vdim == 2 ) {
 394                               print RES ','.format_value($probs[$prob][$subp]),"\n";
 395 #                             if ( defined $probs[$prob][$subp] and
 396 #                                  $probs[$prob][$subp] ne '' );
 397                           } elsif ( $vdim == 3 ) {
 398                             for ( my $m = 0; $m < scalar @{$probs[$prob][$subp]}; $m++ ) {
 399                               my $label = $labels[$prob][$subp][$m];
 400                               print RES ','.format_value($label);
 401 #                               if ( defined $label and $label ne '' );
 402                               my $val = $probs[$prob][$subp][$m];
 403                               print RES ','.format_value($val),"\n";
 404 #                               if ( defined $val and $val ne '' );
 405                             }
 406                           } elsif ( $vdim == 4 ) {
 407                             for ( my $m = 0; $m < scalar @{$probs[$prob][$subp]}; $m++ ) {
 408                               my $label;
 409                               if ( $ldim == 3 ) {
 410                                 $label = $labels[$prob][$subp][$m];
 411                               } elsif ( $ldim == 4 ) {
 412                                 $label = $labels[$prob][$subp][0][$m];
 413                               }
 414 #                             if ( defined $label and $label ne '' ) {
 415                                 print RES format_value($label);
 416 #                             } else {
 417 #                               print RES ',';
 418 #                             }
 419                               if( defined $probs[$prob][$subp][$m] ){
 420                                 for ( my $n = 0; $n < scalar @{$probs[$prob][$subp][$m]}; $n++ ) {
 421                                   print RES format_value($probs[$prob][$subp][$m][$n]);
 422 #                                     if ( defined $probs[$prob][$subp][$m][$n] and
 423 #                                          $probs[$prob][$subp][$m][$n] ne '' );
 424                                 }
 425                               }
 426                               print RES "\n";
 427                             }
 428                           }
 429                         }
 430                       }
 431                     }
 432                   }
 433                 }
 434               }
 435             }
 436             close( RES );
 437 # Bortkommenterat 2004-10-10, se ovan
 438 #         }
 439         } else {
 440           debug -> warn( level => 2,
 441                          message => "No subtools defined".
 442                          ", using default printing routine" );
 443         }
 444       }
 445 end print_results
 446
 447 # }}} pre_fork_setup
 448
 449 # {{{ post_fork_analyze
 450
 451 start post_fork_analyze
 452       {
 453         # Runs the post_fork_analyze specific for the subtool
 454         my $sub_post_fork_analyze = $self -> {'subtools'} -> [0];
 455         if ( defined $sub_post_fork_analyze ) {
 456           $sub_post_fork_analyze = $sub_post_fork_analyze.'_post_fork_analyze';
 457           if ( defined( $self -> can( $sub_post_fork_analyze ) ) ) {
 458             $self -> $sub_post_fork_analyze;
 459           }
 460         }
 461         if ( defined $self -> {'results_file'} ) {
 462           #$self -> print_results;
 463         }
 464       }
 465 end post_fork_analyze
 466
 467 # }}} post_fork_analyze
 468
 469 # {{{ setup
 470
 471 start setup
 472       {
 473         $self -> _prepare_model( model_number => $model_number );
 474
 475         # Run the setup specific for the subtool
 476         my $sub_setup = $self -> {'subtools'} -> [0];
 477         if ( defined $sub_setup ) {
 478           $sub_setup = $sub_setup.'_setup';
 479           $self -> $sub_setup( model_number => $model_number );
 480         }
 481       }
 482 end setup
 483
 484 # }}} setup
 485
 486 # {{{ _make_dir
 487
 488 start _make_dir
 489        {
 490          print "Making directory\t\t",$self -> {'directory'},"\n" if $self -> {'debug'};
 491          mkdir( $self -> {'directory'}, 0744 ) unless ( -e $self -> {'directory'} );
 492        }
 493 end _make_dir
 494
 495 # }}} _make_dir
 496
 497 # {{{ run
 498
 499 # results structure:
 500
 501 # {results}
 502 #      |
 503 #      |->[0]                                First model
 504 #      |   |
 505 #      |   |->{own}                          The results from this tool on the first model
 506 #      |   |    |
 507 #      |   |    |->[0]
 508 #      |   |    |   |
 509 #      |   |    |   |->{name}                    e.g. 'parameter.estimates'
 510 #      |   |    |   |
 511 #      |   |    |   |->{labels}
 512 #      |   |    |   |     |
 513 #      |   |    |   |     |->[0]...              e.g. ['TH1', 'TH2', 'TH3'] indexed on problem and sub problem
 514 #      |   |    |   |     |->[1]
 515 #      |   |    |   |     |...
 516 #      |   |    |   |     |->[#problems]
 517 #      |   |    |   |
 518 #      |   |    |   |->{values}
 519 #      |   |    |         |
 520 #      |   |    |         |->[0]                 e.g. [0.21, 20.3, 3] indexed as above
 521 #      |   |    |         |->[1]
 522 #      |   |    |         |...
 523 #      |   |    |         |->[#problems]
 524 #      |   |    |
 525 #      |   |    |->[1]
 526 #      |   |    |   |
 527 #      |   |    |   |->{name}                    e.g. 'standard.errors'
 528 #      |   |    |   |->{labels}
 529 #      |   |    |   |->{values}
 530 #      |   |->{subtools}                   The results from the subtools on the first model
 531 #      |           |
 532 #      |           |->[0]                    First sub tool
 533 #      |           |   |
 534 #      |           |   |->[0]                First model of the prepared models sent to the first sub tool
 535 #      |           |   |   |
 536 #      |           |   |   |->{own}          The first sub tools results on the first model
 537 #      |           |   |   |    |
 538 #      |           |   |   |    |->[0]       First result type
 539 #      |           |   |   |    |   |
 540 #      |           |   |   |    |   |->{name}
 541 #      |           |   |   |    |   |->{labels}
 542 #      |           |   |   |    |   |->{values}
 543 #      |           |   |   |    |
 544 #      |           |   |   |    |->[1]       Second result type
 545 #      |           |   |   |    |   |
 546 #      |           |   |   |    |   |->{name}
 547 #      |           |   |   |    |   |->{labels}
 548 #      |           |   |   |    |   |->{values}
 549 #      |           |   |   |->{subtools}   Another tool level
 550 #      |           |   |   |      ...
 551 #      |           |   |->[1]                Second model of the prepared models sent to the first sub tool
 552 #      |           |   |   |
 553 #      |           |   |   |->{own}          The first sub tools results on the second model
 554 #      |           |   |   |    |
 555 #      |           |   |   |    |->[0]       First result type
 556 #      |           |   |   |    |   |
 557 #      |           |   |   |    |   |->{name}
 558 #      |           |   |   |    |   |->{labels}
 559 #      |           |   |   |    |   |->{values}
 560 #      |           |   |   |    |
 561 #      |           |   |   |    |->[1]       Second result type
 562 #      |           |   |   |    |   |
 563 #      |           |   |   |    |   |->{name}
 564 #      |           |   |   |    |   |->{labels}
 565 #      |           |   |   |    |   |->{values}
 566 #      |           |   |   |->{subtools}   Another tool level
 567 #      |           |   |   |      ...
 568 #      |           |   |   |...
 569 #      |           |   |->[#prepared models] Last model of the prepared models sent to the first sub tool
 570 #      |           |   |   |
 571 #      |           |   |   |->{own}          The first sub tools results on the last model
 572 #      |           |   |   |    |
 573 #      |           |   |   |    |->[0]       First result type
 574 #      |           |   |   |    |   |
 575 #      |           |   |   |    |   |->{name}
 576 #      |           |   |   |    |   |->{labels}
 577 #      |           |   |   |    |   |->{values}
 578 #      |           |   |   |    |
 579 #      |           |   |   |    |->[1]       Second result type
 580 #      |           |   |   |    |   |
 581 #      |           |   |   |    |   |->{name}
 582 #      |           |   |   |    |   |->{labels}
 583 #      |           |   |   |    |   |->{values}
 584 #      |           |   |   |->{subtools}   Another tool level
 585 #      |           |   |   |      ...
 586 #      |           |->[1]                    Second sub tool
 587 #      |           |...
 588 #      |           |->[#tools]             Last sub tool
 589 #      |
 590 #      |->[1]                                Second model. All above repeated for this model.
 591 #      |...
 592 #      |->[#models]                          Last model. As above.
 593
 594 # Prepared_models structure:
 595
 596 # {prepared_models}
 597 #      |
 598 #      |->[0]                                First model
 599 #      |   |
 600 #      |   |->{own}                          The prepared models of this tool using the first model as base
 601 #      |   |    |
 602 #      |   |    |->[0]                       First prep model
 603 #      |   |    |->[1]                       Second prep model
 604 #      |   |    |...
 605 #      |   |    |->[#prep_models]            Last prep model
 606 #      |   |
 607 #      |   |->{subtools}                   The prepared models of the subtools on the first model. Only one sub tool per prepared model above.
 608 #      |           |
 609 #      |           |->[0]                    First model of the models (prepared above) sent to the first sub tool
 610 #      |           |   |
 611 #      |           |   |->{own}              The first sub tools prepared models on its first model
 612 #      |           |   |    |
 613 #      |           |   |    |->[0]           First prep model
 614 #      |           |   |    |->[1]           Second prep model
 615 #      |           |   |    |...
 616 #      |           |   |    |->[#prep_models]Last prep model
 617 #      |           |   |
 618 #      |           |   |->{subtools}
 619 #      |           |
 620 #      |           |->[1]                    Second model of the models (prepared above) sent to the first sub tool
 621 #      |           |   |
 622 #      |           |   |->{own}              The first sub tools prepared models on its second model
 623 #      |           |   |    |
 624 #      |           |   |    |->[0]           First prep model
 625 #      |           |   |    |->[1]           Second prep model
 626 #      |           |   |    |...
 627 #      |           |   |    |->[#prep_models]Last prep model
 628 #      |           |   |
 629 #      |           |   |->{subtools}
 630 #      |           |
 631
 632
 633 start run
 634     {
 635         my $return_dir = getcwd();
 636         chdir( $self -> {'directory'} );
 637
 638         $self -> pre_fork_setup;
 639
 640         my @models = @{$self -> {'models'}};
 641         # Use the thread number of this tool level:
 642         my $threads = ref( $self -> {'threads'} ) eq 'ARRAY' ?
 643             $self -> {'threads'} -> [0] : $self -> {'threads'};
 644
 645         # No point in using more threads than models
 646         $threads = $#models + 1 if ( $threads > $#models + 1);
 647
 648         # Currently parallel execution is not supported on windows platforms
 649         $threads = 1 if( $Config{osname} eq 'MSWin32' );
 650
 651         # Create new forkmanager
 652         my $pm = ext::Parallel::ForkManager -> new($threads) if ( $threads > 1 );
 653
 654         # Store some globals for single-thread mode to make each loop over the models see the same
 655         # (fresh) prepared attributes as in the parallel mode.
 656         my @pre_fork_tools;
 657         my @pre_fork_results;
 658
 659         if ( $threads == 1 ) {
 660             if ( defined $self -> {'tools'} ) {
 661                 @pre_fork_tools = @{$self -> {'tools'}};
 662             }
 663         }
 664
 665         # Loop over the models
 666         for ( my $i = 1; $i <= scalar @models; $i++ ) {
 667             # Spawn new processes
 668             $pm -> start and next if ( $threads > 1 );
 669
 670             # Reset some globals: (only needed for threads==1)
 671             if ( $threads == 1 && defined $self -> {'tools'}) {
 672                 @{$self -> {'tools'}} = @pre_fork_tools;
 673             }
 674
 675             # Make sure that each process gets a unique random sequence:
 676             random_set_seed_from_phrase(random_uniform_integer(1,0,10000*$i));
 677 #           srand(rand()*10000*$i);
 678
 679             # First, run setup
 680             $self -> setup( model_number => $i );
 681
 682             # Run the subtools
 683             my @tool_results = ();
 684             my @tool_models = ();
 685             if ( defined $self -> {'tools'} ) {
 686                 foreach my $tool (@{$self -> {'tools'}}){
 687                     # There is to date (2004-01-27 no tool that creates more than one internal
 688                     # tool. Hence this is a loop of one cycle. But to be general, again...
 689                     # Run the tool:
 690                     my( $returns, $prep_models ) = $tool -> run;
 691                     # push the sub tool's return values
 692                     push ( @tool_results, $returns );
 693                     if ( defined $prep_models ) {
 694                         print( "Inside ",ref($self)," have called $tool $i ",
 695                                scalar @{$prep_models},"\n") if $self -> {'debug'};
 696                         push ( @tool_models, $prep_models );
 697                     } else {
 698                         print "inside ",ref($self)," but no prep_models defined from $tool $i \n"
 699                             if $self -> {'debug'};
 700                     }
 701                     $self -> post_subtool_analyze;
 702                 }
 703
 704             } else {
 705                 die "No tool object to run from tool object.\n";
 706             }
 707
 708             $self -> {'results'}[$i-1]{'subtools'}= \@tool_results;
 709             $self -> {'prepared_models'}[$i-1]{'subtools'} = \@tool_models;
 710
 711             # Analyze the results
 712             $self -> analyze( model_number => $i );
 713
 714             Storable::store( $self -> {'prepared_models'},
 715                              $self -> {'directory'}."/m$i/prepared_models.log" );
 716             if ( $threads > 1 ) {
 717                 Storable::store( $self -> {'results'},
 718                                  $self -> {'directory'}."/m$i/results.log" );
 719                   # Maybe redundant to transfer back both prepared_models as well as tools
 720                   Storable::store( $self -> {'tools'},
 721                                    $self -> {'directory'}."/m$i/tools.log" );
 722               }
 723             $pm -> finish if ( $threads > 1 );
 724         }
 725         $pm -> wait_all_children if ( $threads > 1 );
 726
 727         my $dbh;
 728         if ( $PsN::config -> {'_'} -> {'use_database'} ) {
 729           $dbh = DBI -> connect("DBI:mysql:host=localhost;databse=psn",
 730                                 "psn", "psn_test",
 731                                 {'RaiseError' => 1});
 732         }
 733
 734         for( my $i = 1; $i <= scalar @{$self -> {'models'}}; $i++ ) {
 735           my @prepared_models = @{Storable::retrieve( $self -> {'directory'}.
 736                                                       "/m$i/prepared_models.log" )};
 737           $self->{'prepared_models'}[$i-1] = $prepared_models[$i-1];
 738
 739           if ( $PsN::config -> {'_'} -> {'use_database'} ) {
 740             my $sth;
 741             foreach my $model ( @{$prepared_models[$i-1]{'own'}} ) {
 742               $sth = $dbh -> prepare("INSERT INTO psn.tool_model (tool_id,".
 743                                      "model_id,prepared_model) ".
 744                                      "VALUES ('".$self -> {'tool_id'}."', ".
 745                                      $model -> model_id.", 1 )");
 746               $sth -> execute;
 747               $sth -> finish;
 748             }
 749           }
 750         }
 751
 752         if ( $PsN::config -> {'_'} -> {'use_database'} ) {
 753           $dbh -> disconnect;
 754         }
 755
 756         if ( $threads > 1 ) {
 757             for( my $i = 1; $i <= scalar @{$self -> {'models'}}; $i++ ) {
 758                 my @model_results = @{Storable::retrieve( $self -> {'directory'}.
 759                                                               "/m$i/results.log" )};
 760 # It is important that to keep the number of dimensions: push the first value, not the
 761 # whole array!
 762                 $self->{'results'}[$i-1] = $model_results[$i-1];
 763                 push( @{$self -> {'tools'}},
 764                       Storable::retrieve( $self -> {'directory'}.
 765                                           "/m$i/tools.log" ) );
 766             }
 767         }
 768
 769
 770         # Perform analyses that need to be done after all models have
 771         # been run and processed. Also write a result file if one is
 772         # defined.
 773         $self -> post_fork_analyze;
 774
 775         chdir($return_dir);
 776         @results     = @{$self -> {'results'}};
 777         @prepared_models = @{$self -> {'prepared_models'}};
 778       }
 779 end run
 780
 781 # }}} run
 782
 783 # {{{ _prepare_model
 784
 785 start _prepare_model
 786       {
 787
 788           my ($newdir, $newfile) = OSspecific::absolute_path( $self -> {'directory'} .  '/m'.$model_number, '' );
 789           debug -> warn( level   => 2,
 790                          message => "Making directory\t\t" . $newdir );
 791           mkdir( $newdir , 0744 );
 792       }
 793 end _prepare_model
 794
 795 # }}} _prepare_model
 796
 797 # {{{ analyze
 798
 799 start analyze
 800       {
 801         my $sub_analyze = $self -> {'subtools'} -> [0];
 802         if ( defined $sub_analyze ) {
 803           $sub_analyze = $sub_analyze.'_analyze';
 804           if( defined $self -> can( $sub_analyze ) ){
 805             $self -> $sub_analyze( model_number => $model_number );
 806           }
 807         }
 808       }
 809 end analyze
 810
 811 # }}} analyze
 812
 813 # {{{ post_subtool_analyze
 814
 815 start post_subtool_analyze
 816     {
 817         my $sub_analyze = $self -> {'subtools'} -> [0];
 818         if ( defined $sub_analyze ) {
 819             $sub_analyze = $sub_analyze.'_post_subtool_analyze';
 820             if( defined $self -> can( $sub_analyze ) ){
 821                 $self -> $sub_analyze( model_number => $model_number );
 822             }
 823         }
 824     }
 825 end post_subtool_analyze
 826
 827 # }}} analyze
 828
 829 # {{{ results
 830
 831 # start results
 832 #       {
 833 #         # Run the results specific for the subtool
 834 #         my $sub_results = $self -> {'subtools'} -> [0];
 835 #         if ( defined $sub_results ) {
 836 #             $sub_results = $sub_results.'_results';
 837 #             @results = @{ $self -> $sub_results( accessor => $accessor, format => $format ) };
 838 #         }
 839 #       }
 840 # end results
 841
 842 # }}} results
 843
 844 # {{{ AUTOLOAD
 845
 846 start AUTOLOAD
 847       {
 848         debug -> warn( level => 2,
 849                        message => "Caught method $AUTOLOAD" );
 850         debug -> warn( level => 2,
 851                        message => "arguments: @_" );;
 852         my %parm = @_;
 853         my $original_models = $parm{'original_models'};
 854         delete( $parm{'original_models'} );
 855         my $class = $parm{'class'};
 856         $AUTOLOAD =~ s/.*://;
 857         return if $AUTOLOAD eq 'DESTROY';
 858
 859 # TODO: Kolla att orginalmodellen körs med submetod i run!!!!! kolla också var resultaten
 860 # läggs!!!
 861
 862         if ( $class =~ /tool::/ ) {
 863           delete( $parm{'mod_array'} );
 864           delete( $parm{'original_models'} );
 865           delete( $parm{'class'} );
 866           @_ = %parm;
 867           if ( defined $self -> {'tools'} ) {
 868             my @tools = @{$self -> {'tools'}};
 869             my $accessor = $AUTOLOAD;
 870             foreach my $tool_ref ( @tools ) {
 871               foreach my $tool ( @{$tool_ref} ) {
 872                 if ( $tool -> can( $accessor ) ) {
 873                   print "Before\n";
 874                   push( @result, $tool -> $accessor( @_ ) );
 875                   print "After\n";
 876                 } else {
 877                   'debug' -> die(message => "Accessor $accessor is not available in the tool " . ref($tool) );
 878                 }
 879               }
 880             }
 881           } else {
 882             print "AUTOLOAD in ",ref($self)," caught tool $AUTOLOAD. It was ",
 883               "supposed to be run by the sub tools but no sub tools were defined\n";
 884           }
 885         } else {
 886           my @models;
 887           my @prep_models;
 888           if ( $original_models ) {
 889             @models = @{$self -> {'models'}};
 890           } elsif ( defined $self -> {'prepared_models'} ) {
 891             print "Using prepared models\n" if $self -> {'debug'};
 892             @prep_models = @{$self -> {'prepared_models'}};
 893           } else {
 894             print "WARNING: tool -> AUTOLOAD: no prepared models available\n";
 895           }
 896
 897           sub models_traverse {
 898             my %parm  = @_;
 899             my $mod_array_ref = $parm{'mod_array'};
 900             my $class     = $parm{'class'};
 901             delete( $parm{'mod_array'} );
 902             delete( $parm{'class'} );
 903             @_ = %parm;
 904             my @mod_array;
 905             @mod_array = defined $mod_array_ref ? @{$mod_array_ref} : ();
 906             my @inner_result = ();
 907             #             my $i = 0;
 908             for ( my $i = 0; $i <= $#mod_array; $i++ ) {
 909               foreach my $model ( @{$mod_array[$i]{'own'}} ) {
 910                 unless ( defined $class ) {
 911                   my $mod_can = defined $model -> can( $AUTOLOAD ) ? 1 : 0;
 912                   my $out_can = (defined $model -> outputs and
 913                                  defined $model -> outputs -> [0] and
 914                                  defined $model -> outputs -> [0] -> can($AUTOLOAD))
 915                     ? 1 : 0;
 916                   my $dat_can = (defined $model -> datas and
 917                                  defined $model -> datas -> [0] and
 918                                  defined $model -> datas -> [0] -> can($AUTOLOAD))
 919                     ? 1 : 0;
 920                   if ( ($mod_can + $out_can + $dat_can) > 1 ) {
 921                     my $classes;
 922                     $classes = 'model ' if $mod_can;
 923                     $classes = $classes.'output ' if $out_can;
 924                     $classes = $classes.'data ' if $dat_can;
 925                     'debug' -> die( message => "Accessor $AUTOLOAD available in multiple classes: $classes" );
 926                   }
 927                   if ( $mod_can + $out_can + $dat_can == 0 ) {
 928                     'debug' -> die( message => "Accessor $AUTOLOAD is not available in any of the model, ".
 929                                     "output or data classes OR no output or data object available".
 930                                     " through this model" );
 931                   }
 932                   if ( $mod_can ) {
 933                     push( @{$inner_result[$i]{'own'}}, $model -> $AUTOLOAD( @_ ) );
 934                   } elsif ( $out_can ) {
 935                     push( @{$inner_result[$i]{'own'}}, $model -> outputs -> [0] -> $AUTOLOAD( @_ ) );
 936                   } elsif ( $dat_can ) {
 937                     push( @{$inner_result[$i]{'own'}}, $model -> datas -> [0] -> $AUTOLOAD( @_ ) );
 938                   }
 939                 } else {
 940                   if ( $class eq 'model' ) {
 941                     push( @{$inner_result[$i]{'own'}}, $model -> $AUTOLOAD( @_ ) );
 942                   } else {
 943                     my $class_accessor = $class.'s';
 944                     push( @{$inner_result[$i]{'own'}}, $model -> $class_accessor -> [0] -> $AUTOLOAD( @_ ) );
 945                   }
 946                 }
 947               }
 948               #               $i++;
 949               if ( defined $mod_array[$i]{'subtools'} ) {
 950                 push( @{$inner_result[$i]{'subtools'}},
 951                       models_traverse( mod_array => $mod_array[$i]{'subtools'},
 952                                        class     => $class,
 953                                        %parm ) );
 954               }
 955             }
 956             return \@inner_result;
 957           }
 958           if ( $original_models ) {
 959             debug -> warn( level => 2,
 960                            message => "Traversing ".scalar $models[0]{'own'}." model(s)" );
 961             @result = @{models_traverse( mod_array => \@models,
 962                                          %parm )};
 963           } else {
 964             @result = @{models_traverse( mod_array => \@prep_models,
 965                                          %parm )};
 966           }
 967         }
 968       }
 969 end AUTOLOAD
 970
 971 # }}} AUTOLOAD
 972
 973 # {{{ process_results
 974
 975 # sub process_results {
 976 #   my $res_ref = shift;
 977 #   my $pad     = shift;
 978 #   $pad++;
 979 #   foreach my $res ( @{$res_ref} ) {
 980 #     if ( ref ( $res ) eq 'ARRAY' ) {
 981 #       process_results( $res, $pad );
 982 #     } else {
 983 #       print "HEPP ",ref($self)," $i $pad $res\n";
 984 #     }
 985 #   }
 986 # }
 987
 988 # }}}