From e9d37f80084b26ad057683940aa8ab1050402612 Mon Sep 17 00:00:00 2001 From: pontus_pih Date: Tue, 4 Oct 2005 08:57:48 +0000 Subject: [PATCH] A big code cleanout in the modelfit module. Some changes to LSF code, the rest is just dead code removed --- bin/setup.pl | 2 +- diagrams/modelfit.dia | 98 ++- lib/tool/modelfit_subs.pm | 1552 ++++++++------------------------------------- 3 files changed, 332 insertions(+), 1320 deletions(-) diff --git a/bin/setup.pl b/bin/setup.pl index 9dc40d7..f243fcb 100644 --- a/bin/setup.pl +++ b/bin/setup.pl @@ -3,7 +3,7 @@ use Config; use CPAN; use File::Spec; -my $version = '2.1.8-r3'; +my $version = '2.1.9'; my @utilities = ('bootstrap', 'cdd', 'execute', 'llp', 'scm', 'sumo', 'mcs', 'mc_cdd', 'data_stats', 'create_extra_data_model', 'single_valued_columns', 'gam42toconf', 'create_cont_model', 'create_cont_data', 'unwrap_data', 'create_subsets' ); diff --git a/diagrams/modelfit.dia b/diagrams/modelfit.dia index 4340da1..f3d03a5 100644 --- a/diagrams/modelfit.dia +++ b/diagrams/modelfit.dia @@ -65,19 +65,19 @@ - + - + - + - + - + @@ -578,29 +578,6 @@ - #run_extended# - - - #scalar boolean# - - - #0# - - - ## - - - - - - - - - - - - - #summarize# @@ -2873,6 +2850,71 @@ + + + #lsf_submit# + + + ## + + + ## + + + + + + ## + + + + + + + + + + + + + + + + + #model# + + + #mandatory object model# + + + ## + + + ## + + + + + + + + #nm_version# + + + #mandatory scalar integer# + + + ## + + + ## + + + + + + + diff --git a/lib/tool/modelfit_subs.pm b/lib/tool/modelfit_subs.pm index 931dca2..0bc8d08 100644 --- a/lib/tool/modelfit_subs.pm +++ b/lib/tool/modelfit_subs.pm @@ -862,6 +862,59 @@ end ask_user # }}} +# {{{ lsf_submit +start lsf_submit + { + + # This method will submit the nonmem.pm file as a script to the + # LSF system. The nonmem.pm file will use the + # "no_remote_compile" and "no_remote_execution" arguments what + # to do on the remote host. It can either compile or execute or + # both. If only execution is done remote, compilation will + # already be done by a call to nonmem -> compile in + # "run_nonmem". + + my $fsubs = join( ',' , @{$model -> subroutine_files} ); + + # Check for vital lsf options. + unless( $self -> {'lsf_queue'} ){ + if( $PsN::config -> {'_'} -> {'lsf_queue'} ){ + $self -> {'lsf_queue'} = $PsN::config -> {'_'} -> {'lsf_queue'}; + } else { + 'debug' -> die( message => 'No queue specified for lsf run' ); + } + } + + foreach my $lsf_option ( 'lsf_project_name', 'lsf_job_name', 'lsf_resources', 'lsf_ttl', 'lsf_options' ){ + unless( $self -> {$lsf_option} ){ + if( $PsN::config -> {'_'} -> {$lsf_option} ){ + $self -> {$lsf_option} = $PsN::config -> {'_'} -> {$lsf_option}; + } + } + } + + run3( "bsub -e stderr -o stdout -K " . + "-q " . $self -> {'lsf_queue'} . + ($self -> {'lsf_project_name'} ? " -P " . $self -> {'lsf_project_name'} : ' ') . + ($self -> {'lsf_job_name'} ? " -J " . $self -> {'lsf_job_name'} : ' ') . + ($self -> {'lsf_ttl'} ? " -c " . $self -> {'lsf_ttl'} : ' ') . + ($self -> {'lsf_resources'} ? " -r " . $self -> {'lsf_resources'} : ' ') . + $self -> {'lsf_options'} . + " perl -I" . + $PsN::lib_dir ."/../ " . + $PsN::lib_dir . "/nonmem.pm" . + " psn.mod psn.lst " . + $self -> {'nice'} . " ". + $nm_version . " " . + $self -> {'no_remote_compile'} . " " . + $self -> {'no_remote_execution'} . " " . + $fsubs . " " . + $self -> {'nm_directory'} ); + + } +end lsf_submit +# }}} + # {{{ run_nonmem start run_nonmem @@ -969,45 +1022,15 @@ start run_nonmem # }}} } elsif ( $self -> {'run_on_lsf'} and $self -> {'no_remote_execution'} ) { - - # {{{ remote compilation (only) using lsf - my $fsubs = join( ',' , @{$final_model -> subroutine_files} ); - - # Check for vital lsf options. - unless( $self -> {'lsf_queue'} ){ - if( $PsN::config -> {'_'} -> {'lsf_queue'} ){ - $self -> {'lsf_queue'} = $PsN::config -> {'_'} -> {'lsf_queue'}; - } else { - 'debug' -> die( message => 'No queue specified for lsf run' ); - } - } - foreach my $lsf_option ( 'lsf_project_name', 'lsf_resources', 'lsf_ttl', 'lsf_options' ){ - unless( $self -> {$lsf_option} ){ - if( $PsN::config -> {'_'} -> {$lsf_option} ){ - $self -> {$lsf_option} = $PsN::config -> {'_'} -> {$lsf_option}; - } - } - } - run3( "bsub -e stderr -o stdout -K " . - "-q " . $self -> {'lsf_queue'} . - ($self -> {'lsf_project_name'} ? " -P " . $self -> {'lsf_project_name'} : ' ') . - ($self -> {'lsf_job_name'} ? " -J " . $self -> {'lsf_job_name'} : ' ') . - ($self -> {'lsf_ttl'} ? " -c " . $self -> {'lsf_ttl'} : ' ') . - ($self -> {'lsf_resources'} ? " -r " . $self -> {'lsf_resources'} : ' ') . - $self -> {'lsf_options'} . - " perl -I" . - $PsN::lib_dir ."/../ " . - $PsN::lib_dir . "/nonmem.pm" . - " psn.mod psn.lst " . - $self -> {'nice'} . " ". - $nm_version . " " . - $self -> {'no_remote_compile'} . " " . - $self -> {'no_remote_execution'} . " " . - $fsubs . " " . - $self -> {'nm_directory'} ); - # }}} + # lsf_submit will call the "nonmem" module that will + # figure out that we want to compile remotely. If we want + # to compile AND run remotely that will be done in the + # call to "lsf_submit" below. + + $self -> lsf_submit( model => $final_model. + nm_version => $nm_version ); } } @@ -1020,38 +1043,12 @@ start run_nonmem } elsif( $self -> {'run_on_lsf'} ) { - # {{{ submit and execute using lsf - my $fsubs = join( ',' , @{$final_model -> subroutine_files} ); - unless( $self -> {'lsf_queue'} ){ - if( $PsN::config -> {'_'} -> {'lsf_queue'} ){ - $self -> {'lsf_queue'} = $PsN::config -> {'_'} -> {'lsf_queue'}; - } else { - 'debug' -> die( message => 'No queue specified for lsf run' ); - } - } - - unless( $self -> {'lsf_options'} ){ - if( $PsN::config -> {'_'} -> {'lsf_options'} ){ - $self -> {'lsf_options'} = $PsN::config -> {'_'} -> {'lsf_options'}; - } - } + # lsf_submit will call the "nonmem" module that will figure + # out that we want to run remotely. If we are also compiling + # remotely, it will be done from here as well. - run3( "bsub -e stderr -o stdout -K " . - "-q " . $self -> {'lsf_queue'} . - ($self -> {'lsf_project_name'} ? " -P " . $self -> {'lsf_project_name'} : ' ') . - ($self -> {'lsf_job_name'} ? " -J " . $self -> {'lsf_job_name'} : ' ') . - $self -> {'lsf_options'} . - " perl -I" . - $PsN::lib_dir ."/../ " . - $PsN::lib_dir . "/nonmem.pm" . - " psn.mod psn.lst " . - $self -> {'nice'} . " ". - $nm_version . " " . - $self -> {'no_remote_compile'} . " " . - $self -> {'no_remote_execution'} . " " . - $fsubs . " " . - $self -> {'nm_directory'} ); - # }}} + $self -> lsf_submit( model => $final_model, + nm_version => $nm_version ); } elsif ( $self -> {'run_on_nordugrid'} ){ @@ -1308,818 +1305,6 @@ end run_nonmem # }}} -# {{{ _extended_run - -start _extended_run - { - # {{{ Local variables setup - - my $modelfilename = $model -> full_name; - my @datafilenames; - my (@pert_theta_inits, @pert_omega_inits, @pert_sigma_inits); - my (@pert_fixed_thetas, @pert_fixed_omegas, @pert_fixed_sigmas); - - unless( defined $model -> datas ) { - die "No data objects defined in model in modelfit-> extendedRun\n"; - } - - my $outdirectory = $model -> directory; - my $outfilename = $model -> outputs -> [0] -> full_name; - - my @table_names = @{$model -> table_names}; - my @tmp_table_names = (); - my @orig_table_names = (); - for ( my $i = 0; $i <= $#table_names; $i++ ) { - my @tmp_arr; - my @orig_arr; - for ( my $j = 0; $j < scalar @{$table_names[$i]}; $j++ ) { - my ( $dir, $filename ) = OSspecific::absolute_path('.', $table_names[$i][$j]); - push( @orig_arr, $dir.$filename ); - push( @tmp_arr, OSspecific::nopath($table_names[$i][$j]) ); - } - push( @orig_table_names, \@orig_arr ); - push( @tmp_table_names, \@tmp_arr ); - } - @table_names = @orig_table_names; - $model -> table_names( new_names => \@tmp_table_names ); - my $wdir = getcwd; - - # }}} - - # {{{ Directory creation and filecopy - - # Make a temporary directory and run there. - my $tmp_dir = $self -> create_sub_dir( 'subDir' => '/NM_run'.($run_no+1)); - - chdir( $tmp_dir ); - - $final_model = $self -> copy_model_and_input( 'model' => $model, 'source' => $wdir ); - - # }}} - - $tries = 0; - my $j = 1; - my $autorun = $retries+1; - RETRY: while ( $j <= $retries+1) { # Main retry loop. - debug -> warn( level => 2, - message => "Inside\t\ttool::modelfit -> _extended_run, ". - "starting try no $tries" ); - debug -> warn( level => 2, - message => "Inside\t\ttool::modelfit -> _extended_run, ". - "preparing to run NONMEM" ); - #my @msfi_ref = @{$final_model -> record( record_name => 'msfi' )}; - # Check if there is a msfi, if not save initial values for later - #if (scalar(@msfi_ref)==0) - #{ - # print "Save initial values for later pertubation\n" if ($self->{'debug'}); - # @pert_theta_inits = @{$final_model -> initial_values( parameter_type => 'theta' )}; - # @pert_omega_inits = @{$final_model -> initial_values( parameter_type => 'omega' )}; - # @pert_sigma_inits = @{$final_model -> initial_values( parameter_type => 'sigma' )}; - # @pert_fixed_thetas = @{$final_model -> fixed(parameter_type => 'theta')}; - # @pert_fixed_omegas = @{$final_model -> fixed(parameter_type => 'omega')}; - # @pert_fixed_sigmas = @{$final_model -> fixed(parameter_type => 'sigma')}; - #} - - # {{{ ########### Run NONMEM section ########### - - my $silent = ""; - if ( defined $self -> {'silent_logfile'} ) { - debug -> warn( level => 2, - message => "Inside\t\tModel -> _extended_run, ", - "running in silent mode" ); - $silent = $final_model -> run_no.$self -> {'silent_logfile'}; - debug -> warn( level => 2, - message => "\t\tPiping NONMEM output to $silent" ); - $silent = ">".$silent; - } - system( OSspecific::NM_command( $nm_version, - $priority, - 'psn.mod', - 'psn.lst', - $silent ) ); - - # }}} ########### End run NONMEM section ########### - $tries=$j++; - - if ( -e 'psn.lst' ) { - # {{{ Get minimization message from output and check - - my $lst = output -> new ( filename => 'psn.lst', - model_id => $self -> {'model_id'} ); - my $term = $lst -> minimization_successful; - my $minimization_message = $lst -> minimization_message; - my @problems = @{$final_model -> problems}; - my $valid_file = 1; - - die "modelfit -> extended_run: No minimization status found in ",$lst ->filename,".\n" - unless defined $term; - - unless ( $#problems == $#{$term} ) { - if ( $resuming ) { - $valid_file = 0; - } else { - debug -> - warn( level => 1, - message => "modelfit -> extended_run: The number of minimization messages (". - scalar @{$term}.") found in the output file ". - $lst ->filename." do not match ". - "the number of problems (". - scalar @problems.") specified in the model file $modelfilename" ); - #$pm -> finish(0) if ( $threads > 1 ); - } - } - unless ( defined $minimization_message and $#problems == $#{$minimization_message} ) { - if ( $resuming ) { - $valid_file = 0; - } else { - debug -> - warn( level => 1, - message => "modelfit -> extended_run: The number of term messages found in ". - "output file do not match ". - "the number of problems specified in the model file" ); - #$pm -> finish(0) if ( $threads > 1 ); - } - } - - # }}} - - # Check for errors per problem. The implementation below - # does not acknowledge that different problems may - # terminate differently. Only one action may be taken for - # the whole NONMEM model file. - - # Check for errors in first problem when rounding error flag is - # set or when the maxeval flag is set. - # This flags are not valid for multiple problem model files. - if ( $valid_file) { - my ($key,$value); - my $round_rerun = 0; - my $maxeval_rerun = 0; - my $hessian_rerun = 0; - - # Check if there is a msfo file that must be copied to basdir - if ($handle_rounding_errors || $handle_maxevals) { - my $outdir = OSspecific::directory($modelfilename); - my ($option_values, $option_pos ) = - $final_model -> _option_val_pos( name => 'MSFO', - record_name => 'estimation'); - foreach my $msfo ( @{$option_values} ){ - foreach my $filename ( @{$msfo} ){ - debug -> warn( level => 2, - message => "Copying $filename to $outdir" ); - cp( $filename, $outdir); - } - } - } - - if ( $handle_rounding_errors || $handle_hessian_npd) { - debug -> warn( level => 2, - message => "Check for rounding errors or hessian_npd" ); - for ( @{$minimization_message -> [0][0]} ) { - debug -> warn( level => 2, - message => "$_" ); - $round_rerun = 1 if ( /\s*DUE TO ROUNDING ERRORS\s*/); - $hessian_rerun = 1 if ( /\s*NUMERICAL HESSIAN OF OBJ. FUNC. FOR COMPUTING CONDITIONAL ESTIMATE - IS NON POSITIVE DEFINITE\s*/); - debug -> warn( level => 1, - message => "FOUND rounding errors!" ) if ($round_rerun == 1 ); - debug -> warn( level => 1, - message => "FOUND hessian non positive definite" ) - if ( $hessian_rerun == 1 ); - } - if ( ($round_rerun && $handle_rounding_errors) || ($hessian_rerun && $handle_hessian_npd)) { - my @data_ref = @{$final_model -> record( record_name => 'msfi' )}; - - # Check if there is a msfi record and then delete it - if (scalar(@data_ref)!=0) { - debug -> warn( level => 2, - message => "Removing msfi record" ); - $final_model->remove_records(type=>'msfi'); - - # Set the intial values + boundaries to the first values (update theta, omega, sigma) - - debug -> warn( level => 2, - message => "Add theta, omega, sigma" ); - - my @old_problems = @{$model -> problems}; - my @new_problems = @{$final_model -> problems}; - for ( my $i=0; $i <= $#old_problems; $i++ ) { - foreach my $param ( 'thetas', 'omegas', 'sigmas' ) { - $new_problems[$i] -> $param - ( Storable::dclone( $old_problems[$i] -> $param ) ); - } - } - - debug -> warn( level => 2, - message => $final_model->nthetas() - ." number of thetas in final_model" ); - debug -> warn( level => 2, - message => $final_model->nomegas(). - " number of omegas in final_model" ); - debug -> warn( level => 2, - message => $final_model->nsigmas(). - " number of sigmas in final_model" ); - $final_model->_write(); - } - - # Update the msfo file if defined - - my ( $msfo_ref, $junk ) = $final_model -> - _get_option_val_pos( problem_numbers => [0], - name => 'MSFO', - record_name => 'estimation' ); - if ( defined $msfo_ref ) { - my $msfo = @{$msfo_ref}->[0][0]; - $msfo =~ /(\d+)\Z/; - - my $new_num = defined ( $1 ) ? $1+1 : 1; - $msfo =~ s/\d*(\Z)/$new_num$1/; - - debug -> warn( level => 2, - message => "Setting new MSFO to: $msfo" ); - $final_model->_option_val_pos( name => 'MSFO', - record_name => 'estimation', - problem_numbers => [[0]], - new_values => [[$msfo]]); - } - $final_model->{'debug'}=1; - $final_model -> update_inits( from_output => $lst, - update_omegas => 1, - update_sigmas => 1, - update_thetas => 1); - $final_model->{'debug'}=0; - - foreach my $th_num ( @cutoff_thetas ) { - my $init_val = $final_model -> - initial_values( parameter_type => 'theta', - parameter_numbers => [[$th_num]])->[0][0]; - if (abs($init_val)<=$self->{'cutoff'}) { - $final_model->initial_values(parameter_type => 'theta', - parameter_numbers => [[$th_num]], - new_values =>[[0]]); - $final_model->fixed(parameter_type => 'theta', - parameter_numbers => [[$th_num]], - new_values => [[1]] ); - debug -> warn( level => 2, - message => "Fixed a parameter (theta $th_num)" ); - } - } - $final_model -> _write; - $tries = --$j; - next RETRY; - } - } - - if ( $handle_maxevals ) { - debug -> warn( level => 2, - message => "Check for max evals" ); - - for ( @{$minimization_message -> [0][0]} ) { - $maxeval_rerun = 1 if ( /\s*MAX. NO. OF FUNCTION EVALUATIONS EXCEEDED\s*/); - debug -> warn( level => 2, - message => "FOUND max number of eval!" ) - if ($maxeval_rerun == 1 ); - } - #If function eval exceeded - if ($maxeval_rerun==1) { - my ( $msfo_ref, $junk ) = $final_model -> - _get_option_val_pos( problem_numbers => [0], - name => 'MSFO', - record_name => 'estimation' ); - die "modelfit -> _extended_run: handle_maxevals set, but no MSFO option", - " defined in model file ",$final_model -> filename,"\n" - unless ( defined $msfo_ref ); - my $msfi = @{$msfo_ref}->[0][0]; - my $msfo = $msfi; - $msfo =~ /(\d+)\Z/; - my $new_num = defined ( $1 ) ? $1+1 : 1; - $msfo =~ s/\d*(\Z)/$new_num$1/; - debug -> warn( level => 2, - message => "Setting new MSFO to: $msfo" ); - debug -> warn( level => 2, - message => "Setting MSFI to: $msfi" ); - $final_model->_option_val_pos( name => 'MSFO', - record_name => 'estimation', - problem_numbers => [[0]], - new_values => [[$msfo]]); - $final_model->remove_records(type=>'theta'); - $final_model->remove_records(type=>'omega'); - $final_model->remove_records(type=>'sigma'); - $final_model->set_records(type=>'msfi', - record_strings => ["$msfi"]); - $final_model->_write(); - $tries=--$j; - next RETRY; - } - } - my @reruns; - for ( my $problem = 1; $problem <= scalar @problems; $problem++ ) { - next unless ( scalar ( @{$problems[$problem - 1] -> estimations} ) > 0); - next unless ( (defined $problems[$problem - 1] -> simulations and - scalar ( @{$problems[$problem - 1] -> simulations} ) < 1) or - (not $final_model -> is_option_set (name => 'ONLYSIM', - record => 'simulation', - problem_number => $problem ))); - next if (defined $final_model->maxeval(problem_numbers => [$problem - 1]) and - $final_model->maxeval(problem_numbers => [$problem - 1])->[0][0] == 0 ); - - # For now, only do picky when rounding_errors and handle_maxeval isn't true - if ( $term -> [$problem-1][0] ) { - if ( $picky ) { - my $rerun = 0; - for ( @{$minimization_message -> [$problem-1][0]} ) { - $rerun = 1 if ( /0ESTIMATE OF THETA IS NEAR THE BOUNDARY AND/ or - /0PARAMETER ESTIMATE IS NEAR ITS BOUNDARY/ or - /0R MATRIX ALGORITHMICALLY SINGULAR/ or - /0S MATRIX ALGORITHMICALLY SINGULAR/); - debug -> warn( level => 1, - message => "FOUND non-satifying minimization!" ) if ($rerun == 1); - } - push( @reruns, $problem ) if ( $rerun ); - } - } else { - push( @reruns, $problem ); - } - } - - debug -> warn( level => 2, - message => "Number of reruns: " .scalar(@reruns) ); - debug -> warn( level => 2, - message => "j: $j, autorun: $autorun" ); - # If rerun is needed, check with the user what to do. - if ( scalar @reruns < 1 ) { - last; - } else { - if ( $j >= $autorun && $self -> {'ask_if_fail'} ) { - my $num = rand; - open( TMP, ">/tmp/$num" ); - print TMP "START MODEL FILE NAME\n"; - print TMP $model -> filename,"\n"; - print TMP "END MODEL FILE NAME\n"; - foreach my $prob ( @reruns ) { - my @theta_labels = @{$final_model -> labels( parameter_type => 'theta' )}; - my @omega_labels = @{$final_model -> labels( parameter_type => 'omega' )}; - my @sigma_labels = @{$final_model -> labels( parameter_type => 'sigma' )}; - my @theta_inits = @{$final_model -> initial_values( parameter_type => 'theta' )}; - my @omega_inits = @{$final_model -> initial_values( parameter_type => 'omega' )}; - my @sigma_inits = @{$final_model -> initial_values( parameter_type => 'sigma' )}; - print TMP "START PROBLEM NUMBER\n"; - print TMP $prob,"\n"; - print TMP "END PROBLEM NUMBER\n"; - print TMP "START MINIMIZATION_MESSAGE\n"; - print TMP @{$minimization_message -> [$prob-1][0]},"\n"; - print TMP "END MINIMIZATION_MESSAGE\n"; - print TMP "START FINAL GRADIENT\n"; - print TMP join( " ",@{$lst -> final_gradients -> [$prob-1][0]}),"\n"; - print TMP "END FINAL GRADIENT\n"; - print TMP "START OFV\n"; - print TMP $lst -> ofv -> [$prob-1][0],"\n"; - print TMP "END OFV\n"; - print TMP "START INITIAL VALUES THETA\n"; - print TMP join(" ", @{$theta_inits[$prob-1]}),"\n"; - print TMP "END INITIAL VALUES THETA\n"; - print TMP "START INITIAL VALUES OMEGA\n"; - print TMP join(" ", @{$omega_inits[$prob-1]}),"\n"; - print TMP "END INITIAL VALUES OMEGA\n"; - print TMP "START INITIAL VALUES SIGMA\n"; - print TMP join(" ", @{$sigma_inits[$prob-1]}),"\n"; - print TMP "END INITIAL VALUES SIGMA\n"; - print TMP "START LABELS\n"; - print TMP join(" ", (@{$theta_labels[$prob-1]},@{$omega_labels[$prob-1]}, - @{$sigma_labels[$prob-1]})),"\n"; - print TMP "END LABELS\n"; - } - close( TMP ); - my $out = readpipe( "/users/lasse/PsN/Diagrams/test/scm_comm.pl $num ".$lst->filename ); - my @out_per_prob = split("\n",$out); - foreach my $prob ( @reruns ) { - my ( $choice, $rest ) = split( ' ', shift( @out_per_prob ), 2 ); - if ( $choice == 0 ) { - $autorun = $j + $rest; - $retries = $autorun; - } elsif ( $choice == 1 ) { - my ($theta_str,$omega_str,$sigma_str) = split(':',$rest); - my @thetas = split( ' ', $theta_str ); - $final_model -> initial_values( parameter_type => 'theta', - problem_numbers => [$prob], - new_values => [\@thetas], - add_if_absent => 0 ); - $retries = $j+1; - } else { - last RETRY; - } - $final_model -> _write; - } - } - if ( $j < $autorun ) { - my @msfi_ref = @{$final_model -> record( record_name => 'msfi' )}; - # Check if there is a msfi and delete it to run with inits instead - if (scalar(@msfi_ref)!=0) - { - debug -> warn( level => 2, - message => "Removing msfi record to pertubate initials" ); - $final_model->remove_records(type=>'msfi'); - } - $final_model -> restore_inits; - foreach my $prob ( @reruns ) { - debug -> warn( level => 2, - message => "Rerun needed for problem $prob" ); - if ( defined $problems[$prob-1] ) { - $problems[$prob-1] -> set_random_inits ( degree => 0.1*($j-1) ); - debug -> warn( level => 2, - message => "Pertubating problem $prob" ); - } else { - debug -> warn( level => 1, - message => "Output indicates that problem number $prob ". - "did not terminate but no such problem seems ". - "to be defined in this modelfile". - " object." ); - $pm -> finish(0) if ( $threads > 1 ); - } - } - $final_model->_write; - next RETRY; - } - } - } - } # end if (-e psn.lst) - else { - debug -> warn( level => debug::fatal, - message => "NONMEM ran, but gave no lst-file" ); - $pm -> finish(0) if ( $threads > 1 ); - } - } #end while - - # {{{ Moving of output and cleanup - - my $outdir = OSspecific::directory($modelfilename); - cp( 'psn.lst', $outfilename ); - - $final_model -> outputs( [output -> new( directory => $outdirectory, - filename => $outfilename, - model_id => $final_model -> model_id )] ); - - - my $outdir = OSspecific::directory($outfilename); - # my $table_name_ref = $model -> table_names; - # die "$outdir\n"; - # if ( defined $table_name_ref and scalar @{$table_name_ref} >= 0 ) { - # for ( my $i = 0; $i < scalar @{$table_name_ref}; $i++ ) { - # for ( my $j = 0; $j < scalar @{$table_name_ref->[$i]}; $j++ ) { - # my $table = $table_name_ref->[$i][$j]; - # cp( $table, $table_names[$i][$j] ); - # } - # } - # } - # $final_model -> table_names( new_names => \@table_names ); - # $model -> table_names( new_names => \@table_names ); - - # my ($option_values, $option_pos ) = - # $model -> _option_val_pos( name => 'MSFO', - # record_name => 'estimation'); - # foreach my $msfo ( @{$option_values} ){ - # foreach my $filename ( @{$msfo} ){ - # print "Copying $filename to $outdir\n" if $self -> {'debug'}; - # cp( $filename, $outdir); - # } - # } - - if ( $self -> {'remove_temp_files'} ) { - unlink 'FCON', 'FDATA', 'FSTREAM', 'PRDERR'; - } - system('tar cz --remove-files -f nonmem_files.tgz *') - if ( $self -> {'compress'} ); - unlink 'nonmem', 'nonmem6'; - - chdir( $wdir ); - - system ( 'rm -rf '.$tmp_dir ) if ($self -> {'clean'} ); - - # }}} - } -end _extended_run - -# }}} - -# {{{ singleRun - -start singleRun - { - # This is a private method used by "run" and should - # preferably not be executed from outside of this file. - - # {{{ Local variables setup - - my $modelfilename = $model -> full_name; - my @datafilenames; - - unless( defined $model -> datas ) { - die "No data objects defined in model in modelfit-> singleRun\n"; - } - -# my $outdirectory = $model -> outputs -> [0] -> directory; - my $outfilename = $model -> outputs -> [0] -> full_name; - - my @table_names = @{$model -> table_names}; - my @tmp_table_names = (); - my @orig_table_names = (); - for ( my $i = 0; $i <= $#table_names; $i++ ) { - my @tmp_arr; - my @orig_arr; - for ( my $j = 0; $j < scalar @{$table_names[$i]}; $j++ ) { - my ( $dir, $filename ) = OSspecific::absolute_path( $model ->directory, - $table_names[$i][$j] ); - # store full absolute name - push( @orig_arr, $dir.$filename ); - # use short name in psn.mod: - push( @tmp_arr, $filename ); - # push( @tmp_arr, OSspecific::nopath($table_names[$i][$j]) ); - } - push( @orig_table_names, \@orig_arr ); - push( @tmp_table_names, \@tmp_arr ); - } - @table_names = @orig_table_names; - $model -> table_names( new_names => \@tmp_table_names, - ignore_missing_files => 1 ); - - if( $outfilename eq '' ) { - $outfilename = $modelfilename; - $outfilename =~ s/\.mod$/\.lst/; - } - - my $wdir = getcwd; - - # }}} - - # {{{ Directory creation and filecopy - - # Make a temporary directory and run there. - my $tmp_dir = $self -> create_sub_dir( 'subDir' => '/NM_run'.($run_no+1)); - - chdir( $tmp_dir ); - - $final_model = $self -> copy_model_and_data( 'model' => $model, 'source' => $wdir ); - - # }}} - - my $j = 1; - my $autorun = $retries+$j; - RETRY: while ( $j <= $retries+1) { # Main retry loop. - # print "TRY $j of $retries, autorun is $autorun\n"; - debug -> warn( level => 2, - message => "Inside\t\ttool::modelfit -> singleRun, ". - "starting try no $j" ); - debug -> warn( level => 2, - message => "Inside\t\ttool::modelfit -> singleRun, ". - "preparing to run NONMEM" ); - - if ( -e 'psn.lst' ) { - # {{{ Get minimization message from output and check - - my $lst = output -> new ( filename => 'psn.lst', - model_id => $self -> {'model_id'} ); - - my $term = $lst -> minimization_successful; - my $minimization_message = $lst -> minimization_message; - my @problems = @{$final_model -> problems}; - my $valid_file = 1; - - die "modelfit -> singlerun: No minimization status found in ",$lst ->filename,".\n" - unless defined $term; - - unless ( $#problems == $#{$term} ) { - if ( $resuming ) { - $valid_file = 0; - } else { - print( "modelfit -> singlerun: The number of minimization messages (", - scalar @{$term},")\nfound in the output file\n",$lst ->filename,"\ndo not match ". - "the number of problems (", - scalar @problems,") specified in the model file\n$modelfilename\n" ); - $pm -> finish(0) if ( $threads > 1 ); - } - } - unless ( defined $minimization_message and $#problems == $#{$minimization_message} ) { - if ( $resuming ) { - $valid_file = 0; - } else { - print("modelfit -> singlerun: The number of term messages found in ". - "output file do not match ". - "the number of problems specified in the model file!\n" ); - $pm -> finish(0) if ( $threads > 1 ); - } - } - - # }}} - - # Check for errors per problem. The implementation below - # does not acknowledge that different problems may - # terminate differently. Only one action may be taken for - # the whole NONMEM model file. - - # {{{ Check for errors per problem - - if ( $valid_file ) { - my @reruns; - for ( my $problem = 1; $problem <= scalar @problems; $problem++ ) { - my ($key,$value); - next unless ( scalar ( @{$problems[$problem - 1] -> estimations} ) > 0); - next unless ( (defined $problems[$problem - 1] -> simulations and - scalar ( @{$problems[$problem - 1] -> simulations} ) < 1) or - ( not $final_model -> is_option_set (name => 'ONLYSIM', - record => 'simulation', - problem_number => $problem )) ); - next if (defined $final_model->maxeval(problem_numbers => [$problem - 1]) and - $final_model->maxeval(problem_numbers => [$problem - 1])->[0][0] == 0 ); - if ( $term -> [$problem-1][0] ) { - if ( $picky ) { - my $rerun = 0; - for ( @{$minimization_message -> [$problem-1][0]} ) { - $rerun = 1 if ( /0ESTIMATE OF THETA IS NEAR THE BOUNDARY AND/ or - /0PARAMETER ESTIMATE IS NEAR ITS BOUNDARY/ or - /0R MATRIX ALGORITHMICALLY SINGULAR/ or - /0S MATRIX ALGORITHMICALLY SINGULAR/); - print "FOUND non-satifying minimization!\n" if ($rerun == 1); - } - push( @reruns, $problem ) if ( $rerun ); - } - } else { - push( @reruns, $problem ); - } - } - - # }}} - # If rerun is needed, check with the user what to do. - if ( scalar @reruns < 1 ) { - last; - } else { - if ( $j >= $autorun && $self -> {'ask_if_fail'} ) { - my $num = rand; - open( TMP, ">/tmp/$num" ); - print TMP "START MODEL FILE NAME\n"; - print TMP $model -> filename,"\n"; - print TMP "END MODEL FILE NAME\n"; - foreach my $prob ( @reruns ) { - my @theta_labels = @{$final_model -> labels( parameter_type => 'theta' )}; - my @omega_labels = @{$final_model -> labels( parameter_type => 'omega' )}; - my @sigma_labels = @{$final_model -> labels( parameter_type => 'sigma' )}; - my @theta_inits = @{$final_model -> initial_values( parameter_type => 'theta' )}; - my @omega_inits = @{$final_model -> initial_values( parameter_type => 'omega' )}; - my @sigma_inits = @{$final_model -> initial_values( parameter_type => 'sigma' )}; - print TMP "START PROBLEM NUMBER\n"; - print TMP $prob,"\n"; - print TMP "END PROBLEM NUMBER\n"; - print TMP "START MINIMIZATION_MESSAGE\n"; - print TMP @{$minimization_message -> [$prob-1][0]},"\n"; - print TMP "END MINIMIZATION_MESSAGE\n"; - print TMP "START FINAL GRADIENT\n"; - print TMP join( " ",@{$lst -> final_gradients -> [$prob-1][0]}),"\n"; - print TMP "END FINAL GRADIENT\n"; - print TMP "START OFV\n"; - print TMP $lst -> ofv -> [$prob-1][0],"\n"; - print TMP "END OFV\n"; - print TMP "START INITIAL VALUES THETA\n"; - print TMP join(" ", @{$theta_inits[$prob-1]}),"\n"; - print TMP "END INITIAL VALUES THETA\n"; - print TMP "START INITIAL VALUES OMEGA\n"; - print TMP join(" ", @{$omega_inits[$prob-1]}),"\n"; - print TMP "END INITIAL VALUES OMEGA\n"; - print TMP "START INITIAL VALUES SIGMA\n"; - print TMP join(" ", @{$sigma_inits[$prob-1]}),"\n"; - print TMP "END INITIAL VALUES SIGMA\n"; - print TMP "START LABELS\n"; - print TMP join(" ", (@{$theta_labels[$prob-1]},@{$omega_labels[$prob-1]}, - @{$sigma_labels[$prob-1]})),"\n"; - print TMP "END LABELS\n"; - } - close( TMP ); - my $out = readpipe( "/users/lasse/PsN/Diagrams/test/scm_comm.pl $num ".$lst->filename ); - my @out_per_prob = split("\n",$out); - foreach my $prob ( @reruns ) { - my ( $choice, $rest ) = split( ' ', shift( @out_per_prob ), 2 ); - if ( $choice == 0 ) { - $autorun = $j + $rest; - $retries = $autorun; - } elsif ( $choice == 1 ) { - my ($theta_str,$omega_str,$sigma_str) = split(':',$rest); - print "thstr $theta_str\n"; - print "omstr $omega_str\n"; - print "sistr $sigma_str\n"; - my @thetas = split( ' ', $theta_str ); - print "$prob: @thetas\n"; - $final_model -> initial_values( parameter_type => 'theta', - problem_numbers => [$prob], - new_values => [\@thetas], - add_if_absent => 0 ); - $retries = $j+1; - } else { - last RETRY; - } - $final_model -> _write; - } - } - if ( $j < $autorun ) { - $final_model -> restore_inits; - foreach my $prob ( @reruns ) { - debug -> warn( level => debug::warning, - message => "Rerun needed for problem $prob" ); - if ( defined $problems[$prob-1] ) { - $problems[$prob-1] -> set_random_inits ( degree => 0.1*($j-1) ); - } else { - print("Output indicates that problem number $prob did not terminate". - " but no such problem seems to be defined in this modelfile". - " object.\n"); - $pm -> finish(0) if ( $threads > 1 ); - } - } - } - } - } - # }} - } else { - if ( $tries > 0 ) { - print "NONMEM ran, but gave no lst-file\n"; - $pm -> finish(0) if ( $threads > 1 ); - } - } - - # {{{ ########### Run NONMEM section ########### - - my $silent = ""; - if ( defined $self -> {'silent_logfile'} ) { - debug -> warn( level => 2, - message => "Inside\t\tModel -> run, running in silent mode" ); - $silent = $final_model -> run_no.$self -> {'silent_logfile'}; - debug -> warn( level => 2, - message => "\t\tPiping NONMEM output to $silent" ); - $silent = ">".$silent; - } - - # print OSspecific::NM_command( $nm_version, - # $priority, - # 'psn.mod', - # 'psn.lst', - # $silent ); - system( OSspecific::NM_command( $nm_version, - $priority, - 'psn.mod', - 'psn.lst', - $silent ) ); - - # }}} ########### End run NONMEM section ########### - $tries = $j++; - } - - # }} - - # {{{ Moving of output and cleanup - - cp( 'psn.lst', $outfilename ); - - $final_model -> outputs( [output -> new( filename => $outfilename, - model_id => $final_model -> model_id )] ); - - my $outdir = OSspecific::directory($outfilename); - my $table_name_ref = $model -> table_names; - if ( defined $table_name_ref and scalar @{$table_name_ref} >= 0 ) { - for ( my $i = 0; $i < scalar @{$table_name_ref}; $i++ ) { - for ( my $j = 0; $j < scalar @{$table_name_ref->[$i]}; $j++ ) { - my $table = $table_name_ref->[$i][$j]; - cp( $table, $table_names[$i][$j] ); - } - } - } - $final_model -> table_names( new_names => \@table_names ); - $model -> table_names( new_names => \@table_names ); - - my ($option_values, $option_pos ) = - $model -> _option_val_pos( name => 'MSFO', - record_name => 'estimation'); - foreach my $msfo ( @{$option_values} ){ - foreach my $filename ( @{$msfo} ){ - debug -> warn( level => 2, - message => "Copying $filename to $outdir" ); - cp( $filename, $outdir); - } - } - - if ( $self -> {'remove_temp_files'} ) { - unlink 'FCON', 'FDATA', 'FREPORT','FSUBS', - 'FSUBS.f','LINK.LNK','FSTREAM', 'PRDERR'; - } - unlink 'nonmem', 'nonmem6'; - system('tar cz --remove-files -f nonmem_files.tgz *') - if ( $self -> {'compress'} ); - - chdir( $wdir ); - - system ( 'rm -rf '.$tmp_dir ) if ($self -> {'clean'} ); - - # }}} - } -end singleRun - -# }}} singleRun - # {{{ _grid_proxy_init start _grid_proxy_up @@ -2579,17 +1764,13 @@ start run my $cwd = getcwd(); chdir( $self -> {'directory'} ); -# if( $self -> run_on_nordugrid ){ -# $threads = 1; -# } else { - $threads = $self -> {'threads'}; - $threads = $#models + 1 if ( $threads > $#models + 1); - - # Currently parallel execution is not supported on windows - # platforms. Because of regular expression issues with - # Parallel::Forkmanager. - $threads = 1 if( $Config{osname} eq 'MSWin32' ); -# } + $threads = $self -> {'threads'}; + $threads = $#models + 1 if ( $threads > $#models + 1); + + # Currently parallel execution is not supported on windows + # platforms. Because of regular expression issues with + # Parallel::Forkmanager. + $threads = 1 if( $Config{osname} eq 'MSWin32' ); # Print model-NM_run translation file open( MNT, ">model_NMrun_translation.txt"); @@ -2644,248 +1825,216 @@ start run # }}} -# if( $self -> run_on_nordugrid ){ - -# $self -> {'grid_batch_size'} = $#models + 1 if ( $self -> {'grid_batch_size'} > $#models + 1); - -# $self -> ng_submit(); -# my $jobFiles = $self -> ng_monitor( 'batchSize' => $self -> {'grid_batch_size'} ); -# $self -> ng_retrieve('jobFiles' => $jobFiles ); + # {{{ Local execution -# for( my $i = 1; $i <= scalar @{$self -> {'models'}}; $i++ ) { -# push( @{$self -> {'prepared_models'}[$i-1]{'own'}}, -# $self -> {'models'} -> [$i-1] ); -# } - -# } else { - - # {{{ Local execution - - my $previous_print = 0; - ui -> print( category => 'modelfit', - message => 'Starting '.scalar( @models ).' NONMEM runs: ' ) - unless $self -> {'parent_threads'} > 1; - ui -> print( category => 'scm', - message => 'Starting '.scalar( @models ).' NONMEM runs: ' ); - ui -> print( category => 'cdd', - message => 'Starting '.scalar( @models ).' NONMEM runs: ' ); - my $actual_runs = -1; # Keep track of how many runs we start (only important for the - # sleep statement below ) - for ( my $run = 0; $run <= $#models; $run ++ ) { - $actual_runs++; - if ( $threads > 6 and $actual_runs != 0 and not (($actual_runs)%6) ) { - print "Sleeping 20 seconds\n"; - sleep(20); - } - my $done = 0; - my ( @seed, $tries, $final_model, @evals, $evals_ref ); - if ( $keepforking ) { - if ( -e "./NM_run" . ($run+1) . "/done" ) { - $done = 1; - $actual_runs--; - open( DONE, "./NM_run". ($run+1) ."/done" ); - my @rows = ; - close( DONE ); - my $junk; - ( $tries, $junk ) = split(' ',$rows[1],3); - @evals = split(' ',$rows[2]); - @seed = split(' ',$rows[3]); - shift( @evals ); # get rid of 'evals'-word - shift( @seed ); # get rid of 'seed'-word - random_set_seed( @seed ); - ui -> print( category => 'modelfit', - message => 'Already run: '.( $run + 1 ). - " using ".($tries+1)." attempts" ) + my $previous_print = 0; + ui -> print( category => 'modelfit', + message => 'Starting '.scalar( @models ).' NONMEM runs: ' ) + unless $self -> {'parent_threads'} > 1; + ui -> print( category => 'scm', + message => 'Starting '.scalar( @models ).' NONMEM runs: ' ); + ui -> print( category => 'cdd', + message => 'Starting '.scalar( @models ).' NONMEM runs: ' ); + my $actual_runs = -1; # Keep track of how many runs we start (only important for the + # sleep statement below ) + for ( my $run = 0; $run <= $#models; $run ++ ) { + $actual_runs++; + if ( $threads > 6 and $actual_runs != 0 and not (($actual_runs)%6) ) { + print "Sleeping 20 seconds\n"; + sleep(20); + } + my $done = 0; + my ( @seed, $tries, $final_model, @evals, $evals_ref ); + if ( $keepforking ) { + if ( -e "./NM_run" . ($run+1) . "/done" ) { + $done = 1; + $actual_runs--; + open( DONE, "./NM_run". ($run+1) ."/done" ); + my @rows = ; + close( DONE ); + my $junk; + ( $tries, $junk ) = split(' ',$rows[1],3); + @evals = split(' ',$rows[2]); + @seed = split(' ',$rows[3]); + shift( @evals ); # get rid of 'evals'-word + shift( @seed ); # get rid of 'seed'-word + random_set_seed( @seed ); + ui -> print( category => 'modelfit', + message => 'Already run: '.( $run + 1 ). + " using ".($tries+1)." attempts" ) unless $self -> {'parent_threads'} > 1; - $final_model = model -> new( filename => "./NM_run".($run+1)."/psn.mod", - target => 'disk', - ignore_missing_files => 1, - quick_reload => 1 ); - } - if ( ($run-$previous_print) >= ($#models+1) / 10 - or - $run == 0 - or - $run == $#models ) { - $previous_print = $run; - ui -> print( category => 'modelfit', - message => ($run+1).'...' ) + $final_model = model -> new( filename => "./NM_run".($run+1)."/psn.mod", + target => 'disk', + ignore_missing_files => 1, + quick_reload => 1 ); + } + if ( ($run-$previous_print) >= ($#models+1) / 10 + or + $run == 0 + or + $run == $#models ) { + $previous_print = $run; + ui -> print( category => 'modelfit', + message => ($run+1).'...' ) unless ( $self -> {'parent_threads'} > 1 or $done ); - } - $children[$run] = $pm -> start ( $run ) if ( $threads > 1 and not $done); - sleep(3) if ( $threads > 1 and not $done); - next if( $children[$run] ); - } else { - last; } - - if ( not $done ) { - my $cutoff_thetas; - # Thetas that may be fixed to zero if the go below cutoff - if ((ref( $self -> {'cutoff_thetas'} ) eq 'ARRAY')) { - if ((ref($self -> {'cutoff_thetas'}->[$run]) eq 'ARRAY')) { - $cutoff_thetas = $self->{'cutoff_thetas'}->[$run]; - } else { - $cutoff_thetas = $self->{'cutoff_thetas'}; - } + $children[$run] = $pm -> start ( $run ) if ( $threads > 1 and not $done); + sleep(3) if ( $threads > 1 and not $done); + next if( $children[$run] ); + } else { + last; + } + + if ( not $done ) { + my $cutoff_thetas; + # Thetas that may be fixed to zero if the go below cutoff + if ((ref( $self -> {'cutoff_thetas'} ) eq 'ARRAY')) { + if ((ref($self -> {'cutoff_thetas'}->[$run]) eq 'ARRAY')) { + $cutoff_thetas = $self->{'cutoff_thetas'}->[$run]; } else { - if (defined ($self->{'cutoff_thetas'})) { - die("cutoff_thetas: ". $self->{'cutoff_thetas'}. " is not of the correct type in modelfit->run\n"); - } + $cutoff_thetas = $self->{'cutoff_thetas'}; + } + } else { + if (defined ($self->{'cutoff_thetas'})) { + die("cutoff_thetas: ". $self->{'cutoff_thetas'}. " is not of the correct type in modelfit->run\n"); } - # Handle rounding errors a bit more intelligently - my $handle_rounding_errors = (ref( $self -> {'handle_rounding_errors'} ) eq 'ARRAY') ? + } + # Handle rounding errors a bit more intelligently + my $handle_rounding_errors = (ref( $self -> {'handle_rounding_errors'} ) eq 'ARRAY') ? $self -> {'handle_rounding_errors'} -> [$run] : $self -> {'handle_rounding_errors'}; - # Handle hessian not postiv definite a bit more intelligently - my $handle_hessian_npd = (ref( $self -> {'handle_hessian_npd'} ) eq 'ARRAY') ? + # Handle hessian not postiv definite a bit more intelligently + my $handle_hessian_npd = (ref( $self -> {'handle_hessian_npd'} ) eq 'ARRAY') ? $self -> {'handle_hessian_npd'} -> [$run] : $self -> {'handle_hessian_npd'}; - # Cut-off for setting parameters to zero - my $cutoff = (ref( $self -> {'cutoff'} ) eq 'ARRAY') ? + # Cut-off for setting parameters to zero + my $cutoff = (ref( $self -> {'cutoff'} ) eq 'ARRAY') ? $self -> {'cutoff'} -> [$run] : $self -> {'cutoff'}; - # Restart after maxeval - my $handle_maxevals = (ref( $self -> {'handle_maxevals'} ) eq 'ARRAY') ? + # Restart after maxeval + my $handle_maxevals = (ref( $self -> {'handle_maxevals'} ) eq 'ARRAY') ? $self -> {'handle_maxevals'} -> [$run] : $self -> {'handle_maxevals'}; - my $tweak_inits = (ref( $self -> {'tweak_inits'} ) eq 'ARRAY') ? + my $tweak_inits = (ref( $self -> {'tweak_inits'} ) eq 'ARRAY') ? $self -> {'tweak_inits'} -> [$run] : $self -> {'tweak_inits'}; - my $retries = (ref( $self -> {'retries'} ) eq 'ARRAY') ? + my $retries = (ref( $self -> {'retries'} ) eq 'ARRAY') ? $self -> {'retries'} -> [$run] : $self -> {'retries'}; - my $picky = ref( $self -> {'picky'} ) eq 'ARRAY' ? + my $picky = ref( $self -> {'picky'} ) eq 'ARRAY' ? $self -> {'picky'} -> [$run] : $self -> {'picky'}; - my $significant_digits_rerun = ref( $self -> {'significant_digits_rerun'} ) eq 'ARRAY' ? + my $significant_digits_rerun = ref( $self -> {'significant_digits_rerun'} ) eq 'ARRAY' ? $self -> {'significant_digits_rerun'} -> [$run] : $self -> {'significant_digits_rerun'}; - my $nm_version = ref( $self -> {'nm_version'} ) eq 'ARRAY' ? + my $nm_version = ref( $self -> {'nm_version'} ) eq 'ARRAY' ? $self -> {'nm_version'} -> [$run] : $self -> {'nm_version'}; - - - if ( $self -> {'run_extended'} ) { - ( $tries, $final_model ) = $self -> extended_run ( cutoff => $cutoff, - cutoff_thetas => $cutoff_thetas, - handle_rounding_errors => $handle_rounding_errors, - handle_maxevals => $handle_maxevals, - handle_hessian_npd => $handle_hessian_npd, - handle_bad_inits => $tweak_inits, - model => $models[$run], - nm_version => $nm_version, - picky => $picky, - pm => $pm, - resuming => $resuming, - retries => $retries, - run_no => $run, - threads => $threads); - } else { - ( $tries, $final_model, $evals_ref ) = - $self -> run_nonmem ( cutoff => $cutoff, - cutoff_thetas => $cutoff_thetas, - handle_rounding_errors => $handle_rounding_errors, - handle_maxevals => $handle_maxevals, - handle_hessian_npd => $handle_hessian_npd, - tweak_inits => $tweak_inits, - model => $models[$run], - nm_version => $nm_version, - picky => $picky, - significant_digits_rerun => $significant_digits_rerun, - pm => $pm, - retries => $retries, - run_no => $run, - threads => $threads); - open( DONE, ">>./NM_run". ($run+1) ."/done" ); - @seed = random_get_seed; - @evals = @{$evals_ref} if ( defined $evals_ref ); - print DONE "This file indicates that PsN has run nonmem ", - "and tried its best to get it through using\n$tries number of attempts\n"; - print DONE "evals: @evals\n"; - print DONE "seed: @seed\n"; - close( DONE ); - } - } - - my $label_no = $run+1; - - if ( not $done ) { - # Log the run - my $ui_text = sprintf("%5s",$label_no).','. - sprintf("%20s",$models[$run] -> filename).','; - foreach my $param ( 'ofv', 'minimization_message', 'covariance_step_successful' ) { - my $ests = $final_model -> outputs -> [0] -> $param; - # Loop the problems - for ( my $j = 0; $j < scalar @{$ests}; $j++ ) { - if ( ref( $ests -> [$j][0] ) ne 'ARRAY' ) { - $ests -> [$j][0] =~ s/\n//g; - $ui_text = $ui_text . sprintf("%12s",$ests -> [$j][0]).','; - } else { - # Loop the parameter numbers (skip sub problem level) - for ( my $num = 0; $num < scalar @{$ests -> [$j][0]}; $num++ ) { - $ui_text = $ui_text . sprintf("%12s",$ests -> [$j][0][$num]).','; - } + + + ( $tries, $final_model, $evals_ref ) = + $self -> run_nonmem ( cutoff => $cutoff, + cutoff_thetas => $cutoff_thetas, + handle_rounding_errors => $handle_rounding_errors, + handle_maxevals => $handle_maxevals, + handle_hessian_npd => $handle_hessian_npd, + tweak_inits => $tweak_inits, + model => $models[$run], + nm_version => $nm_version, + picky => $picky, + significant_digits_rerun => $significant_digits_rerun, + pm => $pm, + retries => $retries, + run_no => $run, + threads => $threads); + open( DONE, ">>./NM_run". ($run+1) ."/done" ); + @seed = random_get_seed; + @evals = @{$evals_ref} if ( defined $evals_ref ); + print DONE "This file indicates that PsN has run nonmem ", + "and tried its best to get it through using\n$tries number of attempts\n"; + print DONE "evals: @evals\n"; + print DONE "seed: @seed\n"; + close( DONE ); + + } + + my $label_no = $run+1; + + if ( not $done ) { + # Log the run + my $ui_text = sprintf("%5s",$label_no).','. + sprintf("%20s",$models[$run] -> filename).','; + foreach my $param ( 'ofv', 'minimization_message', 'covariance_step_successful' ) { + my $ests = $final_model -> outputs -> [0] -> $param; + # Loop the problems + for ( my $j = 0; $j < scalar @{$ests}; $j++ ) { + if ( ref( $ests -> [$j][0] ) ne 'ARRAY' ) { + $ests -> [$j][0] =~ s/\n//g; + $ui_text = $ui_text . sprintf("%12s",$ests -> [$j][0]).','; + } else { + # Loop the parameter numbers (skip sub problem level) + for ( my $num = 0; $num < scalar @{$ests -> [$j][0]}; $num++ ) { + $ui_text = $ui_text . sprintf("%12s",$ests -> [$j][0][$num]).','; } } } - - open( LOG, ">>".$self -> {'logfile'} ); - print LOG $ui_text; - print LOG "\n"; - close LOG; - - ui -> print( category => 'bootstrap', - message => $ui_text, - wrap => 0 ); - ui -> print( category => 'modelfit', - message => $ui_text, - wrap => 0 ); - } else { - print sprintf( "%8s", "$run\r" ); } - my $nl = $run == $#models ? "" : "\r"; - ui -> print( category => 'scm', - message => ui -> status_bar( sofar => $run, - goal => $#models ) . $nl, - wrap => 0, - newline => 0 ); - ui -> print( category => 'cdd', - message => ui -> status_bar( sofar => $run, - goal => $#models ) . $nl, - wrap => 0, - newline => 0 ); - if ( $threads > 1 and not $done) { - $pm -> finish ( join(',',($tries,@evals)) ); - } else { - push( @{$self -> {'prepared_models'}[$run]{'own'}}, $final_model ); - push( @{$self -> {'ntries'}}, $tries ); - push( @{$self -> {'evals'}}, \@evals ); - } - } - if ( $threads > 1 ){ - - # Nice spinner. We make this call here, since we don't want - # a spinner when forking. - unless( $self -> {'parent_threads'} > 1 ){ - my @spinner = ("\\","|","\/","-"); - my $spinner_index = 0; - $pm -> run_on_wait( - sub { - ui -> print( category => 'modelfit', - newline => 0, - message => " \r" . $spinner[$spinner_index] ); - $spinner_index++; - $spinner_index = $spinner_index % 4; - } - , 0.3 ); - } - $pm -> wait_all_children; - - print " \r" unless( $self -> {'parent_threads'} > 1 ); + + open( LOG, ">>".$self -> {'logfile'} ); + print LOG $ui_text; + print LOG "\n"; + close LOG; + + ui -> print( category => 'bootstrap', + message => $ui_text, + wrap => 0 ); + ui -> print( category => 'modelfit', + message => $ui_text, + wrap => 0 ); + } else { + print sprintf( "%8s", "$run\r" ); } - - ui -> print( category => 'cdd', - message => " ... done" ); + my $nl = $run == $#models ? "" : "\r"; ui -> print( category => 'scm', - message => " ... done" ); - ui -> print( category => 'modelfit', - message => "Done.\nWaiting for NONMEM runs to finish" ) - unless $self -> {'parent_threads'} > 1; - - # }}} -# } + message => ui -> status_bar( sofar => $run, + goal => $#models ) . $nl, + wrap => 0, + newline => 0 ); + ui -> print( category => 'cdd', + message => ui -> status_bar( sofar => $run, + goal => $#models ) . $nl, + wrap => 0, + newline => 0 ); + if ( $threads > 1 and not $done) { + $pm -> finish ( join(',',($tries,@evals)) ); + } else { + push( @{$self -> {'prepared_models'}[$run]{'own'}}, $final_model ); + push( @{$self -> {'ntries'}}, $tries ); + push( @{$self -> {'evals'}}, \@evals ); + } + } + if ( $threads > 1 ){ + + # Nice spinner. We make this call here, since we don't want + # a spinner when forking. + unless( $self -> {'parent_threads'} > 1 ){ + my @spinner = ("\\","|","\/","-"); + my $spinner_index = 0; + $pm -> run_on_wait( + sub { + ui -> print( category => 'modelfit', + newline => 0, + message => " \r" . $spinner[$spinner_index] ); + $spinner_index++; + $spinner_index = $spinner_index % 4; + } + , 0.3 ); + } + $pm -> wait_all_children; + + print " \r" unless( $self -> {'parent_threads'} > 1 ); + } + + ui -> print( category => 'cdd', + message => " ... done" ); + ui -> print( category => 'scm', + message => " ... done" ); + ui -> print( category => 'modelfit', + message => "Done.\nWaiting for NONMEM runs to finish" ) + unless $self -> {'parent_threads'} > 1; + + # }}} # my $dbh; # if ( $PsN::config -> {'_'} -> {'use_database'} ) { @@ -3025,182 +2174,3 @@ start run end run # }}} run - - -# # {{{ ng_monitor - -# start ng_monitor -# { -# open( JOB, "<" , $jobidfile ) or die "unable to open jobid file\n"; - -# my @jobs = ; -# close( JOB ); - -# my %jobs; -# my %jobNames; - -# foreach my $job ( @jobs ){ -# chomp($job); -# $jobs{$job} = 'SUBMITTED'; -# } -# my $nr_running_jobs = @jobs; - -# my $job; -# my $eager = 0; -# my $first_poll = 1; # Do some polling emediataly -# my $time; -# while( $nr_running_jobs > 0 ){ - -# if( $eager or $first_poll ){ -# $first_poll = 0; -# $time = 60; -# } else { -# $time = defined $self -> {'grid_poll_interval'} ? $self -> {'grid_poll_interval'} : -# $nr_running_jobs * $self -> {'grid_batch_size'} * $self -> {'cpu_time'} * 1.2 * 60 * 0.5; -# } -# unless( $eager ){ -# print "Polling T - " . $time . "\n"; #" (or press \'f\' to force an update)\n"; -# } - -# my $slept = 0; -# while( $slept < $time ) { -# if( $PsN::config -> {'_'} -> {'use_keyboard'} ) { -# my $key = readkey(); -# if( $key eq 'f' ){ -# print "Forced Poll\n"; -# last; -# } -# } -# $slept += sleep(10); -# } - -# my @status; -# run3( "ngstat -i $jobidfile 2> /dev/null", -# undef, \@status ); -# print "status: @status"; -# my $became_eager = 0; -# foreach my $stat (@status){ -# if( $stat =~ /Job (gsiftp:\/\/.*)/ ){ -# $job = $1; -# } elsif( $stat =~ /Jobname: (.*)/ ){ -# $jobNames{$job} = $1; -# } elsif( $stat =~ /Status: (.*)/ ){ -# my $new_status = $1; -# if( $new_status eq 'FINISHING' ){ -# print "Job [ $job ] is Finishing, polling every minute.\n"; #" (or press \'f\' to force an update)\n"; -# $eager = 1; -# $became_eager = 1; -# } -# if( $jobs{$job} ne $new_status ){ -# if( $jobs{$job} ne 'FAILED' ){ -# print "Job [ $job ] changed status from $jobs{$job} to $1. There are $nr_running_jobs running.\n"; -# $jobs{$job} = $new_status; -# if( $new_status =~ /FINISHED/ ){ -# unless($became_eager){ -# $eager = 0; -# } -# $nr_running_jobs --; -# } -# } -# } -# } elsif( $stat =~ /Error: (.*)/ ) { -# my $error = $1; -# if( $jobs{$job} =~ /FINISHED/ ){ -# debug -> warn( level => 1, -# message => "Job $job Failed: $error" ); -# $jobs{$job} = 'FAILED'; -# } -# } else { -# # print "Found nothing: $stat"; -# } -# } -# } - -# foreach my $job ( keys %jobs ){ -# if( $jobs{$job} =~ /FINISHED/ ){ -# # $jobNames{$job} =~ /nonmem_run_([0-9]*)/; -# # my $indexStart = $1; -# # my $indexStart = ($run+1); -# $job =~ /\/([0-9]*)$/; -# my $jobID = $1; -# my @jobFiles; -# # my $real_batch_size; -# # if( $indexStart + $batchSize > @{$self -> {'models'}} ){ -# # $real_batch_size = @{$self -> {'models'}} - $indexStart; -# # } else { -# # $real_batch_size = $batchSize; -# # } -# # for( my $i = 0; $i < $real_batch_size; $i++ ){ -# # my $dir = $self -> {'directory'}.'/NM_run'.($i+$indexStart).'/'; -# my $dir = $self -> {'directory'}.'NM_run'.($run+1).'/'; -# push( @jobFiles, [ $dir.$jobID.'/PRDERR', $dir.'PRDERR' ]); -# push( @jobFiles, [ $dir.$jobID.'/psn.lst', $dir.'psn.lst' ]); -# # } -# $jobFiles{$job} = \@jobFiles; -# } -# } -# } - -# end ng_monitor - -# # }}} - -# start ng_retrieve -# { -# unless( $self -> _grid_proxy_up ){ -# # if( system( 'ngget', '-i',$jobidfile ) ){ -# # die "ngget failed: $!\n"; -# # } -# my $dir = $self -> {'directory'}.'/NM_run'.($run+1).'/'; -# # my ( $out, $err ); -# my $command = "ngget -i $jobidfile -dir $dir"; -# # run3 does not work here. We need the command to finish -# if ( system( $command ) ) { -# debug -> die( message => "system command $command returned: $!" ); -# } -# # print "NGGET OUT: $out\n"; -# # print "NGGET ERR: $err\n"; -# # if( system( 'ngget', '-i',$jobidfile ) ){ -# # die "ngget failed: $!\n"; -# # } -# } else { -# die "Could not get gridjob, since grid-proxy-init failed\n"; -# } - -# foreach my $key( keys %jobFiles ){ -# my @files = @{$jobFiles{$key}}; -# foreach my $source_n_dest ( @files ){ -# cp($source_n_dest -> [0], $source_n_dest -> [1]); -# } -# } -# print Dumper \%jobFiles; -# # my @models = @{$self -> {'models'}}; -# # for( my $i = 0; $i <= $#models; $i++ ){ - -# # my $final_model = model -> new( filename => $self -> {'directory'}.'/NM_run'.($run+1).'/psn.mod' ); - -# # print "output model: ", $self -> {'models'} -> [$run] -> full_name, "\n"; - -# # chdir( $self -> {'directory'}.'/NM_run'.($run+1) ); -# # $self -> copy_model_and_output( final_model => $final_model, -# # model => $self -> {'models'} -> [$run] ); - -# # my $outfilename = @{$models[$i] -> outputs}[0] -> filename; -# # my $modelfilename = $models[$i] -> filename; -# # unless ( defined $outfilename ) { -# # ($outfilename = $modelfilename) =~ s/\.mod$//; -# # $outfilename = $outfilename.'.lst'; -# # } -# # -# # cp( 'NM_run'. ($i+1) . '/psn.lst', $outfilename ); -# # $models[$i] -> outputfile($outfilename); -# # -# # my $label_no = $i+1; -# # mkdir( $self -> {'directory'}."/m$label_no" ); -# # Storable::store( $models[$i], -# # $self -> {'directory'}."/m". -# # $label_no."/prepared_models.log" ); -# # } -# } - -# end ng_retrieve -- 2.11.4.GIT