lib/data/individual_subs.pm

   1 # {{{ include
   2
   3 start include statements
   4 use debug;
   5 use ui;
   6 end include
   7
   8 # }}} include statements
   9
  10
  11 start new
  12       {
  13         # The idnumber attribute does not have an explicit default value but
  14         # is, if no number is given, instead set to the value of the first
  15         # id column which is assumed only to contain one value.
  16         #
  17         # Either subject_data or init_data must be given. Subject data is
  18         # a two-dimensional array holding the values of the subject. Init_data
  19         # is an one-dimensional array of strings, probably extracted from a
  20         # file where each row is one element in the array. This array is the
  21         # parsed by the constructor and moved to subject_data.
  22
  23         die "Error in data::individual -> new: No ID column specified.\n"
  24            unless ( defined $this -> {'idcolumn'} );
  25         if ( defined $this -> {'subject_data'} ) {
  26           if ( ! defined $this -> {'idnumber'} ) {
  27             my @data = split( /,/ , $this -> {'subject_data'} -> [0]);
  28             $this -> idnumber(@data[$this -> {'idcolumn'}-1] );
  29           }
  30         } else {
  31           die "Error in data::individual -> new: No init_data specified.\n"
  32             unless ( defined $this -> {'init_data'} );
  33           $this -> _read_data;
  34         }
  35       }
  36 end new
  37
  38 start copy
  39         my @new_data = ();
  40         foreach my $row ( @{$self -> subject_data} ) {
  41           my $new_row = $row;
  42           push ( @new_data, $new_row );
  43         }
  44         $individual_copy =
  45            data::individual -> new ( idcolumn     => $self -> {'idcolumn'},
  46                                      idnumber     => $self -> {'idnumber'},
  47                                      subject_data => \@new_data );
  48 end copy
  49
  50 # {{{ diff
  51 start diff
  52 {
  53   my @data      = @{$self -> {'subject_data'}};
  54   my @diff_data = @{$against_individual -> subject_data};
  55   for ( my $i = 0; $i <= $#data; $i++ ) {
  56     my @data_row = split( /,/ , $data[$i] );
  57     my @diff_data_row = split( /,/ , $diff_data[$i] );
  58     if( $largest ) {
  59       for( my $j = 0; $j <= $#columns; $j++ ) {
  60         my $diff = $data_row[$columns[$j]-1] - $diff_data_row[$columns[$j]-1];
  61         $diff = abs($diff) if( $absolute_diff );
  62         if( $diff_as_fraction ) {
  63           if ( defined $diff_data_row[$columns[$j]-1] and not $diff_data_row[$columns[$j]-1] == 0 ) {
  64             $diff = $diff/$diff_data_row[$columns[$j]-1];
  65           } elsif ( not $diff == 0 ) { # If $diff == 0 we can leave it as it is even if we formally
  66             print "ID: ",$self -> {'idcolumn'}," ID2: ",$against_individual -> idcolumn,"\n";
  67             print "DATA1: ",join("\n",@data),"\n";
  68             print "DATA2: ",join("\n",@diff_data),"\n";
  69             # would require a division by the original value
  70             debug -> die( message => "The difference of column ".$columns[$j].
  71                           " was requested as a fraction but the original value was ".
  72                           "found to be zero: a division is impossible." );
  73           }
  74         }
  75 #       print "T: ",($data_row[$columns[$j]-1] - $diff_data_row[$columns[$j]-1])/$diff_data_row[$columns[$j]-1],"\n" if ( $self -> {'idnumber'} == 1332 );
  76 #       print "\t",$data_row[$columns[$j]-1],"\t",$diff_data_row[$columns[$j]-1],"\t$diff" if ( $self -> {'idnumber'} == 1332 );
  77         if( not defined $diff_results{$columns[$j]} or
  78             not defined $diff_results{$columns[$j]}{'diff'} or
  79             $diff > $diff_results{$columns[$j]}{'diff'} ) {
  80           $diff_results{$columns[$j]}{'diff'} = $diff;
  81           $diff_results{$columns[$j]}{'self'} = $data_row[$columns[$j]-1];
  82           $diff_results{$columns[$j]}{'test'} = $diff_data_row[$columns[$j]-1];
  83         }
  84       }
  85  #     print "\n" if ( $self -> {'idnumber'} == 1332 );
  86     } else {
  87       die "individual -> diff is only implemented for finding the largest difference at any observation at this point\n";
  88     }
  89   }
  90 }
  91 end diff
  92 # }}} diff
  93
  94 # {{{ drop_columns
  95 start drop_columns
  96       {
  97         my @new_data;
  98         my @data = @{$self -> {'subject_data'}};
  99         for( my $i = 0; $i <= $#data; $i++ ) {
 100           my @new_row;
 101           my @data_row = split( /,/, $data[$i] );
 102           for( my $j = 0; $j < scalar @data_row; $j++ ) {
 103             push( @new_row, $data_row[$j] ) if ( not $drop[$j] );
 104           }
 105           push( @new_data, join( ',', @new_row ) );
 106         }
 107         $self -> {'subject_data'} = \@new_data;
 108       }
 109 end drop_columns
 110 # }}} drop_columns
 111
 112 start evaluate_expression
 113         my $new_expr;
 114         my $data = $self -> {'subject_data'};
 115         if ( defined $expression ) {
 116           if ( $all_rows ) {
 117             $result = 1;
 118             foreach my $row ( @{$data} ) {
 119               my @row = split( /,/ , $row );
 120               ( $new_expr = $expression ) =~ s/{}/\$row[ \$column-1 ]/g;
 121               $result = $result*eval( $new_expr );
 122             }
 123           } else {
 124             my @row = split( /,/, $data -> [0] );
 125             ( $new_expr = $expression ) =~ s/{}/\$row[ \$column-1 ]/g;
 126             $result = eval( $new_expr );
 127           }
 128         }
 129 end evaluate_expression
 130
 131 start factors
 132         my @data = @{$self -> {'subject_data'}};
 133         for ( my $i = 0; $i <= $#data; $i++ ) {
 134           my @data_row = split( /,/ , $data[$i] );
 135           push( @{$factors{$data_row[$column-1]}}, $i );
 136         }
 137 end factors
 138
 139 start idnumber
 140         if ( defined $parm ) {
 141           for( my $i = 0 ; $i < scalar(@{$self -> {'subject_data'}}); $i++ ) {
 142             my @row = split( /,/, $self -> {'subject_data'} -> [$i] );
 143             $row[ $self -> {'idcolumn'} - 1 ] = $parm;
 144             $self -> {'subject_data'} -> [$i] = join( ',', @row);
 145           }
 146         }
 147 end idnumber
 148
 149 start recalc_column
 150         my ( $new_expr );
 151         for( my $i = 0 ; $i < scalar(@{$self -> {'subject_data'}}); $i++ ) {
 152           my @row = split( /,/, $self -> {'subject_data'} -> [$i] );
 153           ( $new_expr = $expression ) =~ s/{}/\$row[ \$column-1 ]/g;
 154           $row[ $column-1 ] = eval( $new_expr );
 155           $self -> {'subject_data'} -> [$i] = join( ',', @row);
 156         }
 157 end recalc_column
 158
 159 start _read_data
 160         if ( defined $self -> {'init_data'} ) {
 161           $self -> {'subject_data'} = $self -> {'init_data'};
 162           $self -> {'init_data'} = undef;
 163 #          my @init_data = @{$self -> {'init_data'}};
 164 #         my @last_row;
 165 #          for ( @init_data ) {
 166 #           my @elements = split(/\,\s*|\s+/);
 167 #           push( @{$self -> {'subject_data'}}, \@elements );
 168 #           @last_row = @elements;
 169 #          }
 170 #          $self -> idnumber($last_row[$self -> {'idcolumn'}-1]);
 171 #         $self -> {'init_data'} = undef;
 172         }
 173 end _read_data