#! perl -w scipt
use strict;
use warnings;
use Data::Dumper 'Dumper';
my @file_names;
my $dir = "csv/";
opendir( DIR, $dir ) || die "can't opendir $dir: $!";
@file_names = grep { /^.*.csv/ && -f "$dir/$_" } readdir(DIR);
closedir DIR;
my $File_number = 0;
my @place_type;
my @place_name;
my @place_tag;
my @reglookup;
open( DIR_A_prep, "$dir/$file_names[0]" )
|| die "can't open file $file_names[0]: $!";
while (<DIR_A_prep>) {
if ( $_ =~
m/^([^,]+),([^,]+),\d+,\d+,\d+,\d+,,\d+,\d+,\d+,\d+,,\d+,\d+,\d+,\d+/
)
{
my $place_tag_string = $1 . "_" . $2;
my $reglookup_tag_string = $1 . "," . $2;
print
"\n>>>>>>>>>>>>>>>>>>>>>>\n$reglookup_tag_string\n>>>>>>>>>>>>>>>>>>>>
+>>.\n";
$place_tag_string =~ s/ /\_/g;
# $place_tag_string =~ s/\\s/\_/g;
$place_tag_string =~ s/\"//g;
$reglookup_tag_string =~ s/ /\\s/g;
$reglookup_tag_string =~ s/\,/\\,/g;
$reglookup_tag_string =~ s/\"/\\"/g;
$reglookup_tag_string =~ s/\(/\\(/g;
$reglookup_tag_string =~ s/\)/\\(/g;
$reglookup_tag_string =~ s/\&/\\&/g;
push( @place_type, $1 );
push( @place_name, $2 );
push( @place_tag, $place_tag_string );
push( @reglookup, $reglookup_tag_string );
}
}
close DIR_A_prep;
my $array_position = -1;
foreach (@place_tag) {
next unless defined($_);
$_ =~ s/ /\\s/g;
$array_position++;
print "\n@@@@@@@@@@\n\n$reglookup[$array_position]\n\n";
foreach my $file_name (@file_names) {
next unless defined($file_name);
my $rl = $reglookup[$array_position];
my $pt = $place_tag[$array_position];
$File_number++;
print "\n\n\n\n$rl, $dir, $file_name, $File_number, $pt\n\n\n\
+n";
print_out_files( $rl, $dir, $file_name, $File_number, $pt );
}
}
sub print_out_files {
my %files;
my ( $reglookup, $dir, $file_name, $File_number, $place_tag ) = @_
+;
my $Is_it_printed = 0;
$files{Outfile} = "Result/Result_$place_tag.txt";
$files{Outfile_B} = "Result/Result_B_$place_tag.txt";
open( OUTFILE, "+>", $files{Outfile} )
|| die "Can't create output file $files{Outfile}: $!";
open( OUTFILE_B, "+>", $files{Outfile_B} )
|| die "Can't create output file $files{Outfile_B}: $!";
print "$file_name\n";
open( DIR_A, "<$dir/$file_name" ) || die "can't open file $file_na
+me: $!";
my $Sex_specificity;
while ( my $line = <DIR_A> ) {
my %cat;
my $Cause_of_death_string;
my $Cause_of_death_ICD;
if ( $File_number == 1 ) {
$files{First}{name} = $file_name;
if ( $line =~ /^Statistic,([^,]*),,*/ ) {
$files{First}{statistic} = $1;
print OUTFILE_B "\n$files{First}{statistic}";
}
if ( $line =~ /^Age Group,([^,]*),,*/ ) {
$files{First}{age_group} = $1;
print OUTFILE_B "\n$files{First}{age_group}";
}
if ( $line =~ /^Period,([^,]*),,*/ ) {
$files{First}{period} = $1;
print OUTFILE_B "\n$files{First}{period}";
}
if ( $line =~ /^Scale,"{0,1}([^,]*)"{0,1},/ ) {
$files{First}{scale} = $1;
# print OUTFILE_B "\n$files{First}{scale";
}
} else {
$files{Current}{name} = $file_name;
fail( 'statistic method', %files )
if $line =~ /^Statistic,([^,]*),,*/
and $files{First}{statistic} ne $1;
fail( 'age group', %files )
if $line =~ /^Age Group,([^,]*),,*/
and $files{First}{age_group} ne $1;
fail( 'time period', %files )
if $line =~ /^Period,([^,]*),,*/ and $files{First}{perio
+d} ne $1;
fail( 'time period', %files )
if $line =~ /^Scale,"{0,1}([^,]*)"{0,1},/
and $files{First}{scale} ne $1;
}
if ( $_ =~ /^Go to SHA,,MALES,,,,,FEMALES,,,,,PERSONS,,,/ ) {
$Sex_specificity = "Both";
} elsif ( $_ =~ /^Go to SHA,,MALES,,,\n/ ) {
$Sex_specificity = "Males";
} elsif ( $_ =~ /^Go to SHA,,FEMALES,,,\n/ ) {
$Sex_specificity = "Females";
}
if ( $_ =~ /^Indicator\,\"{0,1}(.+)\"{0,1},,/ ) {
print OUTFILE $1 . "\t";
if ( $line =~
/^Indicator\,\"{0,1}([^(]*)(\([^)]*\))\"{0,1}\:\"{0,1}
+,,/ )
{
$Cause_of_death_string = $1;
$Cause_of_death_ICD = $2;
}
}
if ( $_ =~ m/^ENG\,ENGLAND,([^\n]+)/ )
{ # Match any character except new line
my @pos_A = split /\,/, $1;
print "This is pos_A: @pos_A \n\n";
assignParams( $cat{EngWales}{$_}, splice @pos_A, 0, 4 )
for qw(First Second Third);
}
if ( $_ =~ m/^$reglookup\,([^\n]+)/ ) {
my @pos = split /\,/, $1;
assignParams( $cat{PlaceX}{$_}, splice @pos, 0, 4 )
for qw(First Second Third);
}
}
if ( defined $Sex_specificity ) {
print OUTFILE_B <<"CAUSE";
Cause of death\tICD-10\tM\tF\tAll\t Obs\tDSR\tL 95% CI\tU 95% CI\tE&W
+Obs\tE&W DSR\tE&W L 95% CI\tE&W U 95% CI
CAUSE
}
if ( $Sex_specificity eq "Both" ) {
# Do what needs doing here
} elsif ( $Sex_specificity eq "Males" ) {
# Do what needs doing here
} elsif ( $Sex_specificity eq "Females" ) {
# Do what needs doing here
}
close DIR_A;
close OUTFILE;
close OUTFILE_B;
}
sub fail {
my ( $error, %files ) = @_;
print
"There is a '$error' inconsistency between $files{Current}name and $fi
+les{First}{name}";
unlink $files{Outfile};
unlink $files{Outfile_B};
exit;
}
sub assignParams {
my ( $hash, @params ) = @_;
$hash->{observed} = $params[0];
$hash->{DSRs} = $params[1];
$hash->{Lower_95_Confidence_Limits} = $params[2];
$hash->{Upper_95_Confidence_Limits} = $params[3];
}
which is about half the length and includes the following changes:
- cleaned up with PerlTidy using default settings (which includes removing "extra" blank lines)
- use a hash for the file name related variables
- use a hash for the "cat" parameter related variables
- use three parameter open
- remove unused global variables
- make all variables as local as possible
- avoid the same name for scalar and array variables
- use $var++ rather than $var = $var + 1
- refactor error reporting code into a fail sub
- use elsif as appropriate to indicate exclusive if clauses
- remove "one use" variables
- refactor parameter extraction code into a assignParams sub
- refactor repeated print code into a single if ( defined $Sex_specificity ) controlled print
The "bug" may be due to the exit (now in sub fail) btw.
DWIM is Perl's answer to Gödel
| 