lib/gof_crc.pm

   1 package gof_crc;
   2
   3 use strict;
   4
   5 sub test {
   6   return sub {
   7     my ( $calling_scm, $direction, $basic_model, $model_number, $ofv_ch_ref ) = @_;
   8     my @ofv_changes = @{$ofv_ch_ref};
   9
  10     my %ofv_test     = ( 'forward'  => 0.05,
  11                          'backward' => 0.01 );
  12     my %iiv_test     = ( 'IVCL' => { 'forward'  => -0.05,
  13                                      'backward' => 0.1 },
  14                          #                   'IVKA' => { 'forward'  => -0.15,
  15                          #                               'backward' => 0.3 },
  16                          'IVV'  => { 'forward'  => -0.10,
  17                                      'backward' => 0.2 } );
  18     my %extreme_test = ( 'TVCL' => { 'forward'  => 0.1,
  19                                      'backward' => -0.2 },
  20                          #                     'TVKA' => { 'forward'  => 0.20,
  21                          #                     'backward' => -0.4 },
  22                          'TVV'  => { 'forward'  => 0.15,
  23                                      'backward' => -0.3 }, );
  24
  25     my @step_relations   = @{$calling_scm -> step_relations};
  26     my @competing_models = @{$calling_scm -> prepared_models -> [$model_number-1]{'own'}};
  27
  28
  29     my ( $junk, $junk, $junk, $os_ref, $ofv_ref, @junk ) =
  30         $calling_scm -> gof_ofv( $direction,
  31                                  $basic_model,
  32                                  $model_number,
  33                                  $ofv_ch_ref );
  34 #     my ( $os_ref, $ofv_ref ) = &sign_ofv_drops( calling_scm  => $calling_scm,
  35 #                                               model_number => $model_number,
  36 #                                               direction    => $direction,
  37 #                                               ofv_test     => \%ofv_test );
  38     my ( $is_ref, $id_ref ) = &sign_iiv_changes( calling_scm  => $calling_scm,
  39                                                  model_number => $model_number,
  40                                                  direction    => $direction,
  41                                                  iiv_test     => \%iiv_test );
  42     my ( $es_ref, $ed_ref ) = &sign_extreme_changes( calling_scm  => $calling_scm,
  43                                                      model_number => $model_number,
  44                                                      direction    => $direction,
  45                                                      extreme_test => \%extreme_test );
  46
  47     my %ofv_sign     = %{$os_ref};
  48     my @ofv_drop     = @{$ofv_ref};
  49     my %iiv_sign     = %{$is_ref};
  50     my @iiv_drop     = @{$id_ref};
  51     my %extreme_sign = %{$es_ref};
  52     my @extreme_drop = @{$ed_ref};
  53
  54
  55     my $chosen_ofv;
  56     my $resulting_model;
  57     my ( $chosen_parameter, $chosen_covariate );
  58     my %chosen_iiv_sign;
  59     my %chosen_stats_sign;
  60     my %chosen_iiv;
  61     my %chosen_extreme;
  62 #    my %clin_sign = ( %iiv_sign, %extreme_sign );
  63
  64     # Båda riktningarna:
  65     # OFV sign: om droppen är större än den angivna gränsen
  66     # IIV_sign: om droppen (skillnaden) är större än den angivna gränsen
  67     # extreme_sign: om droppen (skillnaden) är större än den angivna gränsen
  68
  69     open( LOG, ">>".$calling_scm->logfile->[$model_number-1] );
  70     my %sign;
  71     if ( $direction eq 'forward' ) {
  72       # Forward:
  73       # Om droppen är ofv_sign och antingen iiv_sign eller extreme_sign:
  74       # välj den med störst positivt drop.
  75       print LOG   "CRITERIA:  IF( ofv_sign AND ( iiv_sign OR extreme_sign ) )\n";
  76       for ( my $i = 0; $i <= $#competing_models; $i++ ) {
  77         my $od = defined $ofv_sign{$i} ? 1 : 0;
  78         my $id = defined $iiv_sign{$i} ? 1 : 0;
  79         my $ed = defined $extreme_sign{$i} ? 1 : 0;
  80         print LOG sprintf("%-8s",$step_relations[$i]{'parameter'}.
  81                             $step_relations[$i]{'covariate'}.'-'.
  82                             $step_relations[$i]{'state'}),
  83                             "     (    $od     AND (    $id     OR      $ed       ) ) = ",
  84           ($od and ($id or $ed ) ),"\n";
  85         $sign{$i} = $ofv_drop[$i] if ($od and ($id or $ed ) );
  86       }
  87     } else {
  88       # Backward:
  89       # Om droppen är ofv_(un)sign eller ( iiv_(un)sign och extreme_(un)sign för alla tester):
  90       # välj den med minst negativt drop
  91       print LOG   "CRITERIA:  IF( ofv_sign OR ( iiv_sign AND extreme_sign ) )\n";
  92       for ( my $i = 0; $i <= $#competing_models; $i++ ) {
  93         my $od = defined $ofv_sign{$i} ? 1 : 0;
  94         my ( $id, $ed ) = (1,1);
  95         while ( my ( $name, $ref ) = each %iiv_test ) {
  96           $id = 0 unless ( defined $iiv_sign{$i}{$name} );
  97         }
  98         while ( my ( $name, $ref ) = each %extreme_test ) {
  99           $ed = 0 unless ( defined $extreme_sign{$i}{$name}{'upper_relative_range'} );
 100           $ed = 0 unless ( defined $extreme_sign{$i}{$name}{'lower_relative_range'} );
 101         }
 102         print LOG sprintf("%-8s",$step_relations[$i]{'parameter'}.
 103                             $step_relations[$i]{'covariate'}.'-'.
 104                             $step_relations[$i]{'state'}),
 105                             "     (    $od     OR (    $id     AND      $ed       ) ) = ",
 106           ($od or ($id and $ed ) ),"\n";
 107         $sign{$i} = $ofv_drop[$i] if ( $od or ( $id and $ed ) );
 108       }
 109     }
 110     close (LOG);
 111     if ( scalar keys %sign > 0) {
 112       my @sorted_ids = sort { $sign{$b} <=> $sign{$a} } keys %sign;
 113       $resulting_model = $competing_models[$sorted_ids[0]];
 114       $chosen_ofv = $competing_models[$sorted_ids[0]] -> outputs -> [0] -> ofv -> [0][0];
 115       $chosen_parameter = $step_relations[$sorted_ids[0]]{'parameter'};
 116       $chosen_covariate = $step_relations[$sorted_ids[0]]{'covariate'};
 117       %chosen_extreme = %{$extreme_drop[$sorted_ids[0]]} if ( defined $extreme_drop[$sorted_ids[0]] );
 118       %chosen_iiv = %{$iiv_drop[$sorted_ids[0]]} if ( defined $iiv_drop[$sorted_ids[0]] );
 119     }
 120
 121     my $base_ofv;
 122     if ( defined $calling_scm -> base_criteria_vals and
 123          defined $calling_scm -> base_criteria_vals ->
 124          [$model_number-1] -> {'ofv'} ) {
 125       $base_ofv = $calling_scm -> base_criteria_vals ->
 126           [$model_number-1] -> {'ofv'};
 127     } else {
 128       $base_ofv = $calling_scm -> models -> [$model_number-1] -> outputs -> [0] -> ofv -> [0][0];
 129     }
 130 #    print "BOFV1: ",$base_ofv,"\n";
 131 #    print "BOFV2: ",$basic_model -> outputs -> [0] -> ofv -> [0][0],"\n";
 132     return ( $resulting_model,
 133              $chosen_parameter,
 134              $chosen_covariate,
 135              \%sign,
 136              [\@ofv_drop, \@iiv_drop, \@extreme_drop],
 137              'CRC',
 138              { 'BASE_MODEL_OFV'   => $base_ofv,
 139                'CHOSEN_MODEL_OFV' => $chosen_ofv,
 140                %chosen_iiv,
 141                %chosen_extreme },
 142              {'ofv'       => $chosen_ofv,
 143               'estimates' => \%chosen_iiv,
 144               'stats'     => \%chosen_extreme } );
 145   }
 146 };
 147
 148 sub sign_iiv_changes {
 149   my %parm = @_;
 150   my $calling_scm  = $parm{'calling_scm'};
 151   my $model_number = $parm{'model_number'};
 152   my $direction    = $parm{'direction'};
 153   my %iiv_test     = %{$parm{'iiv_test'}};
 154
 155   my %iiv_sign; # Flag 0|1 for (un)significance
 156
 157   my %base_ests;
 158   if ( defined $calling_scm -> base_criteria_vals and
 159        defined $calling_scm -> base_criteria_vals ->
 160        [$model_number-1] -> {'estimates'} ) {
 161     %base_ests = %{$calling_scm -> base_criteria_vals ->
 162                      [$model_number-1] -> {'estimates'}};
 163   } elsif ( $direction eq 'backward' ) {
 164     die "GOF_CRC: backward search needs a 'base' IIV estimate\n";
 165   } else {
 166     if ( defined $calling_scm -> models -> [$model_number-1] ->
 167          name_val( parameter_type =>  'theta' )->[0][0] and
 168          defined $calling_scm -> models -> [$model_number-1] ->
 169          name_val( parameter_type =>  'omega' )->[0][0] ) {
 170       %base_ests = ( %{$calling_scm -> models -> [$model_number-1] ->
 171                          name_val( parameter_type =>  'omega' )->[0][0]} );
 172     } else {
 173       die "GOF_CRC: OMEGA parameter estimates not available from model",
 174         $calling_scm -> models -> [$model_number-1] -> full_name ,"\n";
 175     }
 176   }
 177
 178   my @models = @{$calling_scm -> prepared_models -> [$model_number-1]{'own'}};
 179   my @ests;
 180   foreach my $model ( @models ) {
 181     my %mod_name_val = ( %{$model -> name_val( parameter_type =>  'omega' )->[0][0]} );
 182     push( @ests, \%mod_name_val );
 183   }
 184
 185   my @step_relations   = @{$calling_scm -> step_relations};
 186   # Clinical relevance of effect on iiv
 187   open( LOG, ">>".$calling_scm->logfile->[$model_number-1] );
 188   my $un = $direction eq 'backward' ? '(UN)' : '';
 189   print LOG sprintf("%-8s",'MODEL'),
 190     sprintf("%12s",'TEST NAME'),
 191       sprintf("%12s",'BASE VAL'),
 192         sprintf("%12s",'NEW VAL'),
 193           sprintf("%50s",'TEST VAL (RELATIVE CHANGE OF SQUARED VALUES)'),
 194             sprintf("%10s","GOAL"),
 195               sprintf("%14s"," $un".'SIGNIFICANT'),"\n";
 196   my $direction = $calling_scm -> search_direction;
 197   for ( my $i = 0; $i <= $#models; $i++ ) {
 198     my $iiv_significant = 0;
 199     while ( my ( $name, $change_ref ) = each %iiv_test ) {
 200       die "No such variable name $name defined in base inter-individual variability\n"
 201         unless defined $base_ests{$name};
 202       my $change = $change_ref -> {$direction};
 203       my $test_val = (sqrt($ests[$i]{$name})-sqrt($base_ests{$name}))
 204         /sqrt($base_ests{$name});
 205       print LOG sprintf("%-8s",$step_relations[$i]{'parameter'}.
 206                             $step_relations[$i]{'covariate'}.'-'.
 207                             $step_relations[$i]{'state'}),
 208         sprintf("%12s",$name.'  '),
 209           sprintf("%12.5f",$base_ests{$name}),
 210             sprintf("%12.5f",$ests[$i]{$name}),
 211               sprintf("%47.5f",$test_val),'  <',
 212                 sprintf("%10.5f",$change);
 213       if ( $test_val < $change ) {
 214         $iiv_significant++;
 215         print LOG sprintf("%12s",'YES!  ');
 216         $iiv_sign{$i}{$name} = 1;
 217       }
 218       print LOG "\n";
 219     }
 220   }
 221   print LOG "\n";
 222   close(LOG);
 223
 224   return ( \%iiv_sign, \@ests );
 225 }
 226
 227 sub sign_extreme_changes {
 228   my %parm = @_;
 229   my $calling_scm = $parm{'calling_scm'};
 230   my $model_number = $parm{'model_number'};
 231   my $direction = $parm{'direction'};
 232   my %extreme_test = %{$parm{'extreme_test'}};
 233
 234   my %extreme_sign; # Flag 0|1 for (un)significance
 235
 236   my @stats;
 237   my %base_stats;
 238
 239   if ( defined $calling_scm -> base_criteria_vals and
 240        defined $calling_scm -> base_criteria_vals ->
 241        [$model_number-1] -> {'stats'} ) {
 242     %base_stats = %{$calling_scm -> base_criteria_vals ->
 243                       [$model_number-1] -> {'stats'}};
 244   } else {
 245     die "GOF_CRC: No table files defined in ",
 246       $calling_scm -> models -> [$model_number-1] -> full_name,"\n" unless
 247         ( defined $calling_scm -> models -> [$model_number-1] -> table_files and
 248           scalar @{$calling_scm -> models -> [$model_number-1] -> table_files} > 0 and
 249           scalar @{$calling_scm -> models -> [$model_number-1] -> table_files -> [0]} > 0 );
 250     $calling_scm -> models -> [$model_number-1] -> table_files ->[0][0] -> target( 'mem' );
 251     my @stat_names = ( 'max', 'min', 'median' );
 252     while ( my ( $name, $change ) = each %extreme_test ) {
 253       foreach my $stat_name ( @stat_names ) {
 254         $base_stats{$name}{$stat_name} = $calling_scm -> models -> [$model_number-1] ->
 255           table_files ->[0][0] -> $stat_name( column_head => $name );
 256       }
 257       $base_stats{$name}{'upper_relative_range'} =
 258         ($base_stats{$name}{'max'}-$base_stats{$name}{'median'})/
 259           $base_stats{$name}{'median'};
 260       $base_stats{$name}{'lower_relative_range'} =
 261         ($base_stats{$name}{'median'}-$base_stats{$name}{'min'})/
 262           $base_stats{$name}{'median'};
 263     }
 264     $calling_scm -> models -> [$model_number-1] -> table_files ->[0][0] -> target( 'disk' );
 265   }
 266
 267   my @models = @{$calling_scm -> prepared_models -> [$model_number-1]{'own'}};
 268   for ( my $i = 0; $i <= $#models; $i++ ) {
 269     $models[$i] -> table_files -> [0][0] -> target( 'mem' );
 270     while ( my ( $name, $change ) = each %extreme_test ) {
 271       foreach my $stat_name ( 'max', 'min', 'median' ) {
 272         $stats[$i]{$name}{$stat_name} = $models[$i] -> table_files ->[0][0] ->
 273           $stat_name( column_head => $name );
 274       }
 275       $stats[$i]{$name}{'upper_relative_range'} =
 276         ($stats[$i]{$name}{'max'}-$stats[$i]{$name}{'median'})/
 277           $stats[$i]{$name}{'median'};
 278       $stats[$i]{$name}{'lower_relative_range'} =
 279         ($stats[$i]{$name}{'median'}-$stats[$i]{$name}{'min'})/
 280           $stats[$i]{$name}{'median'};
 281     }
 282     $models[$i] -> table_files -> [0][0] -> target( 'disk' );
 283   }
 284
 285   my @step_relations   = @{$calling_scm -> step_relations};
 286
 287   # Clinical relevance of the effect on variuos statistics of the estimates
 288   open( LOG, ">>".$calling_scm->logfile->[$model_number-1] );
 289   my $un = $direction eq 'backward' ? '(UN)' : '';
 290   print LOG sprintf("%-8s",'MODEL'),
 291     sprintf("%12s",'TEST NAME'),
 292       sprintf("%12s",'BASE VAL'),
 293         sprintf("%12s",'NEW VAL'),
 294           sprintf("%50s",'TEST VAL (ABSOLUTE CHANGE)'),
 295             sprintf("%10s","GOAL"),
 296               sprintf("%14s"," $un".'SIGNIFICANT'),"\n";
 297   for ( my $i = 0; $i <= $#models; $i++ ) {
 298     my $extreme_significant = 0;
 299     while ( my ( $name, $change_ref ) = each %extreme_test ) {
 300       my $upper_change = $stats[$i]{$name}{'upper_relative_range'} -
 301         $base_stats{$name}{'upper_relative_range'};
 302       my $lower_change = $stats[$i]{$name}{'lower_relative_range'} -
 303         $base_stats{$name}{'lower_relative_range'};
 304       my $change = $change_ref -> {$direction};
 305       print LOG sprintf("%-8s",$step_relations[$i]{'parameter'}.
 306                             $step_relations[$i]{'covariate'}.'-'.
 307                             $step_relations[$i]{'state'}),
 308         sprintf("%12s",$name.'_lower'),
 309           sprintf("%12.5f",$base_stats{$name}{'lower_relative_range'}),
 310             sprintf("%12.5f",$stats[$i]{$name}{'lower_relative_range'}),
 311               sprintf("%47.5f",$lower_change),'  >',
 312                 sprintf("%10.5f",$change);
 313       if ( $lower_change > $change ) {
 314         print LOG sprintf("%12s",'YES!  ');
 315         $extreme_significant++;
 316         $extreme_sign{$i}{$name}{'lower_relative_range'} = 1;
 317       }
 318       print LOG "\n";
 319       print LOG sprintf("%-8s",$step_relations[$i]{'parameter'}.
 320                             $step_relations[$i]{'covariate'}.'-'.
 321                             $step_relations[$i]{'state'}),
 322         sprintf("%12s",$name.'_upper'),
 323           sprintf("%12.5f",$base_stats{$name}{'upper_relative_range'}),
 324             sprintf("%12.5f",$stats[$i]{$name}{'upper_relative_range'}),
 325               sprintf("%47.5f",$upper_change),'  >',
 326                 sprintf("%10.5f",$change);
 327       if ( $upper_change > $change ) {
 328         print LOG sprintf("%12s",'YES!  ');
 329         $extreme_significant++;
 330         $extreme_sign{$i}{$name}{'upper_relative_range'} = 1;
 331       }
 332       print LOG "\n";
 333     }
 334   }
 335   print LOG "\n";
 336   close(LOG);
 337   return ( \%extreme_sign, \@stats );
 338 }
 339
 340 1;