You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
449 lines
22 KiB
449 lines
22 KiB
#!/usr/bin/perl
|
|
|
|
# Source - LikertData.pl
|
|
|
|
# Svn Keywords
|
|
# $Date$
|
|
# $Revision$
|
|
# $Author$
|
|
# $HeadURL$
|
|
# $Id$
|
|
|
|
use FileHandle;
|
|
use Time::Local;
|
|
use Data::Dumper;
|
|
|
|
require 'questionslib.pl';
|
|
require Exporter;
|
|
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
|
|
@ISA = qw(Exporter);
|
|
# Items to export into callers namespace by default. Note: do not export
|
|
# names by default without a very good reason. Use EXPORT_OK instead.
|
|
# Do not simply export all your public functions/methods/constants.
|
|
@EXPORT = qw(GetLikertData);
|
|
@EXPORT_OK = qw();
|
|
$VERSION = '0.01';
|
|
|
|
sub GetLikertData {
|
|
# Parameters
|
|
# $client - required String, client id.
|
|
# $testid - required String, test id.
|
|
# $idlist - optional Hash reference, keys are candidate ids, values are true for desired candidates.
|
|
# Returned value.
|
|
# $ret - reference to a Hash of a Hash. The keys of the first hash are the supercategories
|
|
# of the likert questions in the test. The keys of the second hash are 'PointsAvail',
|
|
# 'Responses', 'NoResponses', 'PointsEarned', and 'ScoreCount'. The values of the first
|
|
# four keys are numeric counts, or score totals. The value of the 'ScoreCount' is
|
|
# another hash. Its keys are the scores, and the values are the counts of the number
|
|
# of times each score was a response.
|
|
my ($client, $testid, $idlist) = @_ ;
|
|
my $ret = {} ;
|
|
my %supercat_found = () ; # hash of categories found and initialized in the hash of hashes.
|
|
&get_test_profile($client, $testid) ; # Populates %TEST
|
|
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid);
|
|
unless (defined $idlist) {
|
|
# warn "In GetLikertData and idlist is undefined." ;
|
|
}
|
|
foreach my $file (@filelist) {
|
|
my $user = $file;
|
|
$user =~ s/.$testid$//; # Strip the test id off the end of the file name.
|
|
$user =~ s/^$client.//; # Strip the client id off the start of the file name.
|
|
if (defined $idlist and %{$idlist} and not $idlist->{$user}) {
|
|
# warn "Skipped completed test for $user ." ;
|
|
# warn "Reference " . ref $idlist . " value." ;
|
|
next;
|
|
}
|
|
my $inact_ques = 0 ; # This is an offset for the inactive questions.
|
|
# The inactive questions are still listed, but without an answer.
|
|
# warn "Process completed test for $user ." ;
|
|
# Process this desired candidate's test answers.
|
|
&get_test_sequence_for_reports($client, $user, $testid) ;
|
|
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS,
|
|
# %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY.
|
|
my $QUESTIONS_AH = get_question_definitions ($CLIENT{'clid'}, $FORM{'tstid'});
|
|
# Populates an array of hashs that contains all of the questions and the answers.
|
|
# $QUESTIONS_AH is a reference to the arrays of hashs.
|
|
my $last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A.
|
|
my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ;
|
|
my $ques_type, $supercat, $scores, @responses, $responses ;
|
|
$responses = $SUBTEST_RESPONSES{2} ;
|
|
# warn "user $user testid $testid resp $responses .\n" ;
|
|
@responses = split (/\&/, $responses) ;
|
|
shift @responses ; # Drop the empty element in front of the list.
|
|
foreach $index1 (0 .. $last_index) {
|
|
# Skip the question if it is inactive.
|
|
if (${$QUESTIONS_AH}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;}
|
|
# Get the data for a single question.
|
|
$points = ${$QUESTIONS_AH}[$index1]->{'pts'} ;
|
|
$weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ;
|
|
$ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ;
|
|
$scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ;
|
|
unless ($ques_type eq "lik") {next ;}
|
|
@scores = split (/\,/ , $scores) ;
|
|
$supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ;
|
|
unless ($supercat_found{$supercat}) {
|
|
# Initialize counters.
|
|
$ret->{$supercat}->{'PointsAvail'} = 0 ;
|
|
$ret->{$supercat}->{'NoResponses'} = 0 ;
|
|
$ret->{$supercat}->{'Responses'} = 0 ;
|
|
$ret->{$supercat}->{'PointsEarned'} = 0 ;
|
|
$ret->{$supercat}->{'ScoreCount'} = {} ;
|
|
$supercat_found{$supercat} = 1 ;
|
|
}
|
|
$responses = $responses[$index1-$inact_ques] ;
|
|
@individ = split(/\?/, $responses) ;
|
|
shift @individ ;
|
|
# warn "2user $user testid $testid resp $responses index1 $index1 prev $responses[$index1-1] next $responses[$index1+1] .\n" ;
|
|
my $no_response = 1 ;
|
|
$ret->{$supercat}->{'PointsAvail'} += $points ;
|
|
foreach $index2 (0 .. $#scores) {
|
|
# Add the key for the score count to the hash.
|
|
unless (exists $ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) {
|
|
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ;
|
|
}
|
|
}
|
|
foreach $index2 (0 .. $#scores) {
|
|
# warn "index2 $index2 individ $individ[$index2] .\n" ;
|
|
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) {
|
|
# Answered this question.
|
|
$ret->{$supercat}->{'PointsEarned'} += $scores[$index2] ;
|
|
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ;
|
|
# warn "Likert Answer supercat $supercat index2 $index2 scores $scores[$index2] \n" ;
|
|
$no_response = 0 ;
|
|
} # If answered.
|
|
} # foreach $index2
|
|
if ($no_response) {
|
|
# Add to the no response count.
|
|
$ret->{$supercat}->{'NoResponses'} ++ ;
|
|
# warn "Likert Answer supercat $supercat No Response \n" ;
|
|
} else {
|
|
# Add to the response count.
|
|
$ret->{$supercat}->{'Responses'} ++ ;
|
|
# warn "Likert Answer supercat $supercat Response \n" ;
|
|
}
|
|
} # foreach question.
|
|
} # foreach file (i.e. candidate)
|
|
$ret ; # Return reference.
|
|
} # End of GetLikertData
|
|
|
|
sub GetLikertGrpData {
|
|
# Parameters
|
|
# $client - required String, client id.
|
|
# $testid - required String, test id.
|
|
# $idlist - required Hash reference, keys are candidate ids, values are group id for desired candidates.
|
|
# Returned values - $ret_all, $ret_grp
|
|
# $ret_all - reference to a Hash of a Hash. The keys of the first hash are the supercategories
|
|
# of the likert questions in the test. The keys of the second hash are 'PointsAvail',
|
|
# 'Responses', 'NoResponses', 'PointsEarned', and 'ScoreCount'. The values of the first
|
|
# four keys are numeric counts, or score totals. The value of the 'ScoreCount' is
|
|
# another hash. Its keys are the scores, and the values are the counts of the number
|
|
# of times each score was a response. Values for candidates will be counted here regardless of
|
|
# group membership.
|
|
# $ret_grp - reference to a Hash of a Hash of a Hash. The keys of the first hash are
|
|
# the group ids. The values are structured like $ret_all.
|
|
my ($client, $testid, $idlist) = @_ ;
|
|
my $ret_all = {} ; my $ret_grp = {} ;
|
|
my %supercat_found = () ; # hash of categories found and initialized in the hash of hashes.
|
|
my $inact_ques = 0; # Count of the inactive questions found.
|
|
&get_test_profile($client, $testid) ; # Populates %TEST
|
|
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid);
|
|
unless (defined $idlist ) {
|
|
warn "In GetLikertData and idlist is undefined." ;
|
|
}
|
|
foreach my $file (@filelist) {
|
|
my $user = $file;
|
|
$user =~ s/.$testid$//; # Strip the test id off the end of the file name.
|
|
$user =~ s/^$client.//; # Strip the client id off the start of the file name.
|
|
my $user_grp = undef ;
|
|
# Process this desired candidate's test answers.
|
|
&get_test_sequence_for_reports($client, $user, $testid) ;
|
|
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS,
|
|
# %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY.
|
|
my $QUESTIONS_AH = get_question_definitions ($CLIENT{'clid'}, $FORM{'tstid'});
|
|
# Populates an array of hashs that contains all of the questions and the answers.
|
|
# $QUESTIONS_AH is a reference to the arrays of hashs.
|
|
my $last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A.
|
|
my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ;
|
|
my $ques_type, $supercat, $scores, @responses, $responses ;
|
|
$responses = $SUBTEST_RESPONSES{2} ;
|
|
@responses = split (/\&/, $responses) ;
|
|
shift @responses ; # Drop the empty element in front of the list.
|
|
foreach $index1 (0 .. $last_index) {
|
|
# Skip the question if it is inactive.
|
|
if (${$QUESTIONS_AH}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;}
|
|
# Get the data for a single question.
|
|
$points = ${$QUESTIONS_AH}[$index1]->{'pts'} ;
|
|
$weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ;
|
|
$ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ;
|
|
$scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ;
|
|
unless ($ques_type eq "lik") {next ;}
|
|
@scores = split (/\,/ , $scores) ;
|
|
$supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ;
|
|
unless ($supercat_found{$supercat}) {
|
|
# Initialize counters.
|
|
# warn "Init all Cat $supercat" if $supercat eq "Employee Passion" ;
|
|
$ret->{$supercat}->{'PointsAvail'} = 0 ;
|
|
$ret->{$supercat}->{'NoResponses'} = 0 ;
|
|
$ret->{$supercat}->{'Responses'} = 0 ;
|
|
$ret->{$supercat}->{'PointsEarned'} = 0 ;
|
|
$ret->{$supercat}->{'ScoreCount'} = {} ;
|
|
$supercat_found{$supercat} = 1 ;
|
|
}
|
|
if (defined $idlist and %{$idlist} and $idlist->{$user}) {
|
|
unless (defined $ret_grp->{$idlist->{$user}}->{$supercat}) {
|
|
# warn "Init grp Cat $supercat user $user Grp $idlist->{$user}" if $supercat eq "Employee Passion" ;
|
|
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsAvail'} = 0 ;
|
|
$ret_grp->{$idlist->{$user}}->{$supercat}->{'NoResponses'} = 0 ;
|
|
$ret_grp->{$idlist->{$user}}->{$supercat}->{'Responses'} = 0 ;
|
|
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsEarned'} = 0 ;
|
|
$ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'} = {} ;
|
|
}
|
|
}
|
|
$responses = $responses[$index1-$inact_ques] ;
|
|
@individ = split(/\?/, $responses) ;
|
|
shift @individ ;
|
|
my $no_response = 1 ;
|
|
$ret->{$supercat}->{'PointsAvail'} += $points ;
|
|
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsAvail'} += $points ;
|
|
# warn "ADD USER $user GRP $idlist->{$user} PNTS $points TOT $ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsAvail'}" if $supercat eq "Employee Passion" ;
|
|
foreach $index2 (0 .. $#scores) {
|
|
# Add the key for the score count to the hash.
|
|
unless (exists $ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) {
|
|
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ;
|
|
}
|
|
unless (exists $ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) {
|
|
$ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ;
|
|
}
|
|
}
|
|
# warn "CHECKING CAT $supercat USER $user GRP $idlist->{$user}" if $supercat eq "Employee Passion" ;
|
|
foreach $index2 (0 .. $#scores) {
|
|
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) {
|
|
# Answered this question.
|
|
# warn "Scored CAT $supercat POINTS $scores[$index2] USER $user GRP $idlist->{$user}" if $supercat eq "Employee Passion" ;
|
|
$ret->{$supercat}->{'PointsEarned'} += $scores[$index2] ;
|
|
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ;
|
|
$ret_grp->{$idlist->{$user}}->{$supercat}->{'PointsEarned'} += $scores[$index2] ;
|
|
$ret_grp->{$idlist->{$user}}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ;
|
|
$no_response = 0 ;
|
|
} # If answered.
|
|
} # foreach $index2
|
|
if ($no_response) {
|
|
# Add to the no response count.
|
|
$ret->{$supercat}->{'NoResponses'} ++ ;
|
|
$ret_grp->{$idlist->{$user}}->{$supercat}->{'NoResponses'} ++ ;
|
|
} else {
|
|
# Add to the response count.
|
|
$ret->{$supercat}->{'Responses'} ++ ;
|
|
$ret_grp->{$idlist->{$user}}->{$supercat}->{'Responses'} ++ ;
|
|
}
|
|
} # foreach question.
|
|
} # foreach file (i.e. candidate)
|
|
return ($ret, $ret_grp) ; # Return reference.
|
|
} # End of GetLikertGrpData
|
|
|
|
sub GetFullLikertGrpData {
|
|
# Parameters
|
|
# $client - required String, client id.
|
|
# $testid - required String, test id.
|
|
# $grplist - optional Hash reference, keys are group ids, values are like getGroups function.
|
|
# if undef. then only one returned value.
|
|
# $grp_req - optional boolean, default is false. If true, then $ret_all only includes results
|
|
# for users in the $grplist, and $grplist must be provided to get any results.
|
|
|
|
# Returned values - $ret_all, $ret_grp
|
|
# $ret_all - reference to a Hash of a Hash. The keys of the first hash are the supercategories
|
|
# of the likert questions in the test. The keys of the second hash are 'PointsAvail',
|
|
# 'Responses', 'NoResponses', 'PointsEarned', 'ScoreCount', and 'Questions'. The values of the first
|
|
# four keys are numeric counts, or score totals. The value of the 'ScoreCount' is
|
|
# another hash. Its keys are the scores, and the values are the counts of the number
|
|
# of times each score was a response. Values for candidates will be counted here regardless of
|
|
# group membership. The value of 'Questions' is an un-named hash. The keys of the un-named
|
|
# hash are the question numbers for the supercategory. The value is always 1.
|
|
# $ret_grp - reference to a Hash of a Hash of a Hash. The keys of the first hash are
|
|
# the group ids. The values are structured like $ret_all. This is not returned if
|
|
# the parameter $grplist is not provided, or undef.
|
|
|
|
my ($client, $testid, $grplist,$grp_req) = @_ ;
|
|
# warn "grplist" ;
|
|
# warn &Dumper(\$grplist) ;
|
|
# warn "grp_req $grp_req X\n" ;
|
|
my $ret_all = {} ; my $ret_grp = {} ;
|
|
my %Group_Xref = () ; # List of groups that each member belongs to.
|
|
# The hash key is a member id, the value is an array of the groups he is in.
|
|
# Build the cross reference.
|
|
my $Group = "" ; my $Member = "" ;
|
|
foreach $Group (keys %{${grplist}}) {
|
|
foreach $Member (@{${grplist}->{$Group}->{'grplist'}}) {
|
|
push @{$Group_Xref->{$Member}} , $Group ;
|
|
}
|
|
}
|
|
# warn Dumper(\%Group_Xref) ;
|
|
my %supercat_found = () ; # hash of categories found and initialized in the hash of hashes.
|
|
&get_test_profile($client, $testid) ; # Populates %TEST
|
|
my $QUESTIONS_AH = get_question_definitions ($CLIENT{'clid'}, $FORM{'tstid'});
|
|
# Populates an array of hashs that contains all of the questions and the answers.
|
|
# $QUESTIONS_AH is a reference to the arrays of hashs.
|
|
my $last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A.
|
|
my @filelist = &main::get_test_result_files($main::testcomplete, $client,$testid);
|
|
foreach my $file (@filelist) {
|
|
my $user = $file;
|
|
$user =~ s/.$testid$//; # Strip the test id off the end of the file name.
|
|
$user =~ s/^$client.//; # Strip the client id off the start of the file name.
|
|
my $user_grp = undef ;
|
|
my $inact_ques = 0; # Count of the inactive questions found.
|
|
# Do not process this user if group membership is required and not a member.
|
|
if ($grp_req and not $Group_Xref->{$user}) {
|
|
# warn "Skipped User $user X" ;
|
|
next ;
|
|
}
|
|
# Process this desired candidate's test answers.
|
|
# warn "Process User $user X" ;
|
|
&get_test_sequence_for_reports($client, $user, $testid) ;
|
|
# populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS,
|
|
# %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, and %SUBTEST_SUMMARY.
|
|
my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ;
|
|
my $ques_type, $supercat, $scores, @responses, $responses ;
|
|
$responses = $SUBTEST_RESPONSES{2} ;
|
|
@responses = split (/\&/, $responses) ;
|
|
shift @responses ; # Drop the empty element in front of the list.
|
|
foreach $index1 (0 .. $last_index) {
|
|
# Skip the question if it is inactive.
|
|
if (${$QUESTIONS_AH}[$index1]->{'qil'} eq "Y") {$inact_ques++ ; next ;}
|
|
# Get the data for a single question.
|
|
$points = ${$QUESTIONS_AH}[$index1]->{'pts'} ;
|
|
$weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ;
|
|
$ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ;
|
|
$scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ;
|
|
unless ($ques_type eq "lik") {next ;}
|
|
@scores = split (/\,/ , $scores) ;
|
|
$supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ;
|
|
unless ($supercat_found{$supercat}) {
|
|
# Initialize counters.
|
|
# warn "Init all Cat $supercat" if $supercat eq "Employee Passion" ;
|
|
$ret->{$supercat}->{'PointsAvail'} = 0 ;
|
|
$ret->{$supercat}->{'NoResponses'} = 0 ;
|
|
$ret->{$supercat}->{'Responses'} = 0 ;
|
|
$ret->{$supercat}->{'PointsEarned'} = 0 ;
|
|
$ret->{$supercat}->{'ScoreCount'} = {} ;
|
|
$supercat_found{$supercat} = 1 ;
|
|
}
|
|
$ret->{$supercat}->{'Questions'}->{$index1-$inact_ques} = 1 ;
|
|
my @Groups = @{$Group_Xref->{$user}} ;
|
|
foreach $group (@Groups) {
|
|
unless (defined $ret_grp->{$group}->{$supercat}) {
|
|
# warn "Init all Cat $supercat Group $group.\n" if $supercat eq "Improvement" ;
|
|
$ret_grp->{$group}->{$supercat}->{'PointsAvail'} = 0 ;
|
|
$ret_grp->{$group}->{$supercat}->{'NoResponses'} = 0 ;
|
|
$ret_grp->{$group}->{$supercat}->{'Responses'} = 0 ;
|
|
$ret_grp->{$group}->{$supercat}->{'PointsEarned'} = 0 ;
|
|
$ret_grp->{$group}->{$supercat}->{'ScoreCount'} = {} ;
|
|
}
|
|
} # foreach $group
|
|
$responses = $responses[$index1-$inact_ques] ;
|
|
@individ = split(/\?/, $responses) ;
|
|
shift @individ ;
|
|
my $no_response = 1 ;
|
|
$ret->{$supercat}->{'PointsAvail'} += $points ;
|
|
foreach $group (@Groups) {
|
|
$ret_grp->{$group}->{$supercat}->{'PointsAvail'} += $points ;
|
|
}
|
|
foreach $index2 (0 .. $#scores) {
|
|
# Add the key for the score count to the hash.
|
|
unless (exists $ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) {
|
|
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ;
|
|
}
|
|
unless (exists $ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]}) {
|
|
$ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} = 0 ;
|
|
}
|
|
}
|
|
# warn "CHECKING CAT $supercat USER $user GRP @group RESP $responses \n" if $supercat eq "Improvement" ;
|
|
foreach $index2 (0 .. $#scores) {
|
|
if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) {
|
|
# Answered this question.
|
|
# warn "Scored CAT $supercat POINTS $scores[$index2] USER $user GRP @group \n" if $supercat eq "Improvement" ;
|
|
$ret->{$supercat}->{'PointsEarned'} += $scores[$index2] ;
|
|
$ret->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ;
|
|
foreach $group (@Groups) {
|
|
$ret_grp->{$group}->{$supercat}->{'PointsEarned'} += $scores[$index2] ;
|
|
$ret_grp->{$group}->{$supercat}->{'ScoreCount'}->{$scores[$index2]} ++ ;
|
|
}
|
|
$no_response = 0 ;
|
|
} # If answered.
|
|
} # foreach $index2
|
|
if ($no_response) {
|
|
# Add to the no response count.
|
|
$ret->{$supercat}->{'NoResponses'} ++ ;
|
|
foreach $group (@Groups) {
|
|
$ret_grp->{$group}->{$supercat}->{'NoResponses'} ++ ;
|
|
}
|
|
} else {
|
|
# Add to the response count.
|
|
$ret->{$supercat}->{'Responses'} ++ ;
|
|
foreach $group (@Groups) {
|
|
$ret_grp->{$group}->{$supercat}->{'Responses'} ++ ;
|
|
}
|
|
}
|
|
} # foreach question.
|
|
} # foreach file (i.e. candidate)
|
|
return ($ret, $ret_grp) ; # Return reference.
|
|
} # End of GetFullLikertGrpData
|
|
|
|
sub BuildBarGraph {
|
|
# This subroutine builds the HTML to get an image from an URL.
|
|
# The URL is a cgi-bin PERL script, with several parameters.
|
|
# The list parameters are: labels, values, and values2.
|
|
# The scalar parameters are: xdim, ydim, hbar, title, xlabel, ylabel, ymax, ymin, yticknum, colorscheme, $t_margin, $b_margin, $l_margin, $r_margin
|
|
|
|
# The first 3 parameters are references to three lists, which are mandatory.
|
|
# The values2 list may be an empty list. (and ignored.)
|
|
# The rest of the parameters are optional, but are order specific.
|
|
# Any parameter that is an empty string will be effectively ignored,
|
|
# but may be required to fill the list of parameters to a needed parm.
|
|
my @label_names, @value_points, @value2_points ;
|
|
my $labels_ref, $values_ref, $values2_ref ;
|
|
my $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum ;
|
|
my $colorscheme ;
|
|
my $t_margin, $b_margin, $l_margin, $r_margin ;
|
|
$labels_ref = $_[0] ;
|
|
@label_names = @{$labels_ref} ;
|
|
# @label_names is an array of character strings of the names of the bars on the graph.
|
|
$values_ref = $_[1] ;
|
|
@value_points = @{$values_ref} ;
|
|
# @value_points is an array of numeric values for each of the names in the first array.
|
|
# The sizes of the two arrays should be the same.
|
|
$values2_ref = $_[2] ;
|
|
@value2_points = @{$values2_ref} ;
|
|
shift ; shift ; shift ; # Remove the first 3 parms, to set up the next statement.
|
|
($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme, $t_margin, $b_margin, $l_margin, $r_margin) = @_ ;
|
|
my $labels, $values, $values2 ;
|
|
# print '<br> label_names ' . "@label_names" . ' <br>' ;
|
|
# print '<br> value_points ' . "@value_points" . ' <br>' ;
|
|
if ($#label_names != $#value_points) {
|
|
print '<br>ERROR BuildBarGraph has different number of labels and data values.<br>' ;
|
|
}
|
|
$labels = join (":", map {munge($_)} @label_names ) ;
|
|
$values = join (":", map {munge($_)} @value_points ) ;
|
|
$values2 = join (":", map {munge($_)} @value2_points ) ;
|
|
# my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&title=Trust%20Level&ylabel=Respondents";
|
|
my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&values=$values" ;
|
|
if ($xdim or $xdim == 0) { $baseurl .= "&xdim=" . $xdim ; }
|
|
if ($ydim or $ydim == 0) { $baseurl .= "&ydim=" . $ydim ; }
|
|
if ($hbar or $hbar == 0) { $baseurl .= "&hbar=" . $hbar ; }
|
|
if ($title or $title == 0) { $baseurl .= "&title=" . munge( $title) ; }
|
|
if ($xlabel or $xlabel == 0) { $baseurl .= "&xlabel=" . munge( $xlabel) ; }
|
|
if ($ylabel or $ylabel == 0) { $baseurl .= "&ylabel=" . munge( $ylabel) ; }
|
|
if ($ymax or $ymax == 0) { $baseurl .= "&ymax=" . $ymax ; }
|
|
if ($ymin or $ymin == 0) { $baseurl .= "&ymin=" . $ymin ; }
|
|
if ($t_margin or $t_margin == 0) { $baseurl .= "&t_margin=" . $t_margin ; }
|
|
if ($b_margin or $b_margin == 0) { $baseurl .= "&b_margin=" . $b_margin ; }
|
|
if ($l_margin or $l_margin == 0) { $baseurl .= "&l_margin=" . $l_margin ; }
|
|
if ($r_margin or $r_margin == 0) { $baseurl .= "&r_margin=" . $r_margin ; }
|
|
if ($colorscheme) { $baseurl .= "&colorscheme=" . $colorscheme ; }
|
|
if ($yticknum or $yticknum == 0) { $baseurl .= "&yticknum=" . $yticknum ; }
|
|
return "<img src=\"$baseurl&values2=$values2\">";
|
|
}
|
|
|
|
|
|
|
|
1 ; # End of Perl Library file
|
|
|
|
|