bin/create_extra_data_model

   1 #!/usr/bin/perl
   2
   3 use FindBin qw($Bin);
   4 use lib "$Bin/../lib";
   5
   6 # Don't edit the line below, it must look exactly like this.
   7 # Everything above this line will be replaced #
   8
   9 use PsN;
  10 use model;
  11 use strict;
  12
  13 use Getopt::Long;
  14 use vars qw/ $opt_help /;
  15 use vars qw/ $opt_model
  16              $opt_new_model_name
  17              $opt_extra_data
  18              $opt_header
  19              $opt_debug
  20              $opt_debug_package
  21              $opt_debug_subroutine /;
  22
  23 ## Configure the command line parsing
  24 Getopt::Long::config("auto_abbrev");
  25
  26 ## Declare the options
  27 my $res = GetOptions("help",                 # Display help message
  28                      "model:s",
  29                      "new_model_name:s",
  30                      "extra_data:s",
  31                      "header:s",
  32                      "debug:0",
  33                      "debug_package:s",
  34                      "debug_subroutine:s");
  35
  36 exit unless $res;
  37
  38 if($opt_help or not defined $opt_model) {
  39   print <<'ENDHELP';
  40
  41   create_extra_data_model.pl
  42
  43       Perl script that creates and adds the necessary code for extra data
  44       files (useful when the number of columns exceeds 20)
  45
  46     Usage:
  47
  48       create_extra_data_model -model=filename
  49       -extra_data=extra_data_filename
  50       -header='ID,WGT,APGR'
  51       [-new_model_name=new_filename]
  52
  53
  54     Example:
  55
  56       ./create_extra_data_model -mod=pheno.mod -extra=cov.dta -header='ID,WGT,APGR'
  57                    -new=pheno_extra.mod
  58
  59 ENDHELP
  60   exit;
  61 }
  62
  63 ## Check that we do have a model file
  64 unless ( $opt_model ) {
  65   exit "A model file must be specified\n";
  66 }
  67
  68 ui -> category( 'model' );
  69
  70 debug -> level( $opt_debug );
  71 debug -> package( $opt_debug_package );
  72 debug -> subroutine( $opt_debug_subroutine );
  73
  74 my @header = split(',',$opt_header);
  75
  76 my $model = model -> new ( filename => $opt_model,
  77                            target   => 'disk' );
  78 my $mcopy = $model -> copy( filename  => $opt_new_model_name,
  79                             copy_data => 0 );
  80 $mcopy -> extra_data_files( [$opt_extra_data] );
  81 $mcopy -> extra_data_headers( [\@header] );
  82
  83 $mcopy -> add_extra_data_code;
  84 $mcopy -> write_get_subs;
  85 $mcopy -> write_readers;
  86 $mcopy -> _write;