Fixes to Survey reporting and performance improvements
Fix: Survey export simple/transposed results to csv or tab Fix: loadTempReportTable handling of revisionDates (and documentation) Fix: returnResponseForReporting handling of mc questions NYTProf performance improvements Added some very basic Survey reporting tests
This commit is contained in:
Patrick Donelan
parent
ea51ba559e
commit
280e902c09
8 changed files with 422 additions and 273 deletions
|
|
@ -2390,9 +2390,64 @@ sub www_viewStatisticalOverview {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 export ( $options )
|
||||
|
||||
Triggers the user's browser to download the given content as a file
|
||||
|
||||
Accepts the following options:
|
||||
|
||||
=over 4
|
||||
|
||||
=item content (optional)
|
||||
|
||||
The content to return. If not specified, the sql param is used.
|
||||
|
||||
=item sql (optional)
|
||||
|
||||
An sql string to use to look up content.
|
||||
|
||||
=item sqlParams (optional)
|
||||
|
||||
An array of sql positional parameters.
|
||||
|
||||
=item format
|
||||
|
||||
Either C<csv> or C<tab>
|
||||
|
||||
=item name
|
||||
|
||||
The filename to use for the downloadable content
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub export {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, { content => 0, sql => 0, sqlParams => {default => []}, format => { default => 'csv' }, name => 1 });
|
||||
|
||||
my $format = lc $opts{format};
|
||||
$format = 'csv' unless $format eq 'csv' || $format eq 'tab';
|
||||
|
||||
# Content is either passed in, or we lookup via SQL query
|
||||
my $content = $opts{content};
|
||||
if (!$content) {
|
||||
|
||||
# Use the appropriate SQL 'quick' method
|
||||
my $method = $format eq 'csv' ? 'quickCSV' : 'quickTab';
|
||||
$content = $self->session->db->$method( $opts{sql}, $opts{sqlParams} );
|
||||
}
|
||||
|
||||
my $filename = $self->session->url->escape( $self->get("title") . "_$opts{name}.$format" );
|
||||
$self->session->http->setFilename($filename,"text/$format");
|
||||
return $content;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 www_exportSimpleResults ()
|
||||
|
||||
Exports transposed results in a tab deliniated file.
|
||||
Exports transposed results as CSV (or tabbed depending on the C<format> form param)
|
||||
|
||||
=cut
|
||||
|
||||
|
|
@ -2402,21 +2457,21 @@ sub www_exportSimpleResults {
|
|||
return $self->session->privilege->insufficient()
|
||||
if !$self->session->user->isInGroup( $self->get('groupToViewReports'));
|
||||
|
||||
$self->loadTempReportTable();
|
||||
|
||||
my $filename = $self->session->url->escape( $self->get('title') . '_results.tab' );
|
||||
my $content
|
||||
= $self->session->db->quickTab(
|
||||
'select * from Survey_tempReport t where t.assetId=? order by t.Survey_responseId, t.order',
|
||||
[ $self->getId() ] );
|
||||
return $self->export( $filename, $content );
|
||||
$self->loadTempReportTable( ignoreRevisionDate => 1 );
|
||||
|
||||
return $self->export(
|
||||
sql => 'select * from Survey_tempReport t where t.assetId=? order by t.Survey_responseId, t.order',
|
||||
sqlParams => [ $self->getId() ],
|
||||
format => scalar $self->session->form->process('format'),
|
||||
name => 'simple',
|
||||
);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 www_exportTransposedResults ()
|
||||
|
||||
Returns transposed results as a tabbed file.
|
||||
Returns transposed results as CSV (or tabbed depending on the C<format> form param)
|
||||
|
||||
=cut
|
||||
|
||||
|
|
@ -2425,21 +2480,22 @@ sub www_exportTransposedResults {
|
|||
return $self->session->privilege->insufficient()
|
||||
if !$self->session->user->isInGroup( $self->get('groupToViewReports') );
|
||||
|
||||
$self->loadTempReportTable();
|
||||
|
||||
my $filename = $self->session->url->escape( $self->get('title') . '_transposedResults.tab' );
|
||||
my $content
|
||||
= $self->session->db->quickTab(
|
||||
'select r.userId, r.username, r.ipAddress, r.startDate, r.endDate, r.isComplete, t.*'
|
||||
. ' from Survey_tempReport t'
|
||||
. ' left join Survey_response r using(Survey_responseId)'
|
||||
. ' where t.assetId=?'
|
||||
. ' order by r.userId, r.Survey_responseId, t.order',
|
||||
[ $self->getId() ] );
|
||||
return $self->export( $filename, $content );
|
||||
$self->loadTempReportTable( ignoreRevisionDate => );
|
||||
|
||||
return $self->export(
|
||||
sql => <<END_SQL,
|
||||
select r.userId, r.username, r.ipAddress, r.startDate, r.endDate, r.isComplete, t.*
|
||||
from Survey_tempReport t
|
||||
left join Survey_response r using(Survey_responseId)
|
||||
where t.assetId = ?
|
||||
order by r.userId, r.Survey_responseId, t.order
|
||||
END_SQL
|
||||
sqlParams => [ $self->getId() ],
|
||||
format => scalar $self->session->form->process('format'),
|
||||
name => 'transposed',
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 www_exportStructure
|
||||
|
|
@ -2522,78 +2578,86 @@ END_HTML
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 export($filename,$content)
|
||||
|
||||
Exports the data in $content to $filename, then forwards the user to $filename.
|
||||
|
||||
=head3 $filename
|
||||
|
||||
The name of the file you want exported.
|
||||
|
||||
=head3 $content
|
||||
|
||||
The data you want exported (CSV, tab, whatever).
|
||||
|
||||
=cut
|
||||
|
||||
sub export {
|
||||
my $self = shift;
|
||||
my $filename = shift;
|
||||
$filename =~ s/[^\w\d\.]/_/g;
|
||||
my $content = shift;
|
||||
|
||||
# Create a temporary directory to store files if it doesn't already exist
|
||||
my $store = WebGUI::Storage->createTemp( $self->session );
|
||||
my $tmpDir = $store->getPath();
|
||||
my $filepath = $store->getPath($filename);
|
||||
if ( !open TEMP, ">$filepath" ) {
|
||||
return 'Error - Could not open temporary file for writing. Please use the back button and try again';
|
||||
}
|
||||
print TEMP $content;
|
||||
close TEMP;
|
||||
my $fileurl = $store->getUrl($filename);
|
||||
|
||||
$self->session->http->setRedirect($fileurl);
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 loadTempReportTable
|
||||
|
||||
Loads the responses from the survey into the Survey_tempReport table, so that other or custom reports can be ran against this data.
|
||||
|
||||
Accepts the following options:
|
||||
|
||||
=over 4
|
||||
|
||||
=item ignoreRevisionDate
|
||||
|
||||
Normally it only makes sense to compare responses for the current revisionDate (because the Survey structure can change
|
||||
between revisions). This flag tells us to ignore response revisionDate.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub loadTempReportTable {
|
||||
my $self = shift;
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, { ignoreRevisionDate => 0 });
|
||||
|
||||
my $refs = $self->session->db->buildArrayRefOfHashRefs( 'select * from Survey_response where assetId = ?',
|
||||
[ $self->getId() ] );
|
||||
# Remove old temp report data
|
||||
$self->session->db->write( 'delete from Survey_tempReport where assetId = ?', [ $self->getId() ] );
|
||||
for my $ref (@{$refs}) {
|
||||
$self->responseJSON( undef, $ref->{Survey_responseId} );
|
||||
my $count = 1;
|
||||
for my $q ( @{ $self->responseJSON->returnResponseForReporting() } ) {
|
||||
|
||||
# Build the sql that will select all responses
|
||||
my $sql = 'select * from Survey_response where assetId = ?';
|
||||
|
||||
# Mostly it only makes sense to export responses for a single revisionDate (because Survey
|
||||
# structure can change between revisions)
|
||||
$sql .= ' and revisionDate = ' . $self->session->db->quote($self->get('revisionDate')) unless $opts{ignoreRevisionDate};
|
||||
|
||||
# Populate the temp report table with new data
|
||||
my $refs = $self->session->db->buildArrayRefOfHashRefs( $sql, [ $self->getId() ] );
|
||||
for my $ref ( @{$refs} ) {
|
||||
|
||||
# Inject the responseJSON
|
||||
$self->responseJSON( $ref->{responseJSON}, $ref->{Survey_responseId} );
|
||||
|
||||
my $order = 1;
|
||||
for my $q ( @{ $self->responseJSON->responseReport } ) {
|
||||
if ( @{ $q->{answers} } == 0 and $q->{comment} =~ /\w/ ) {
|
||||
$self->session->db->write(
|
||||
'insert into Survey_tempReport VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)', [
|
||||
$self->getId(), $ref->{Survey_responseId}, $count++, $q->{section},
|
||||
$q->{sectionName}, $q->{question}, $q->{questionName}, $q->{questionComment},
|
||||
undef, undef, undef, undef,
|
||||
undef, undef, undef
|
||||
'insert into Survey_tempReport VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)',
|
||||
[ $self->getId(), # assetId
|
||||
$ref->{Survey_responseId}, # Survey_responseId
|
||||
$order++, # order
|
||||
$q->{section},, # sectionNumber
|
||||
$q->{sectionName}, # sectionName
|
||||
$q->{question}, # questionNumber
|
||||
$q->{questionName}, # questionName
|
||||
$q->{questionComment}, # questionComment
|
||||
undef,
|
||||
undef,
|
||||
undef,
|
||||
undef,
|
||||
undef,
|
||||
undef,
|
||||
undef
|
||||
]
|
||||
);
|
||||
next;
|
||||
}
|
||||
for my $a ( @{ $q->{answers} } ) {
|
||||
$self->session->db->write(
|
||||
'insert into Survey_tempReport VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)', [
|
||||
$self->getId(), $ref->{Survey_responseId}, $count++, $q->{section},
|
||||
$q->{sectionName}, $q->{question}, $q->{questionName}, $q->{questionComment},
|
||||
$a->{id}, $a->{value}, $a->{verbatim}, $a->{time},
|
||||
$a->{isCorrect}, $a->{value}, undef
|
||||
'insert into Survey_tempReport VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)',
|
||||
[ $self->getId(), # assetId
|
||||
$ref->{Survey_responseId}, # Survey_responseId
|
||||
$order++, # order
|
||||
$q->{section}, # sectionNumber
|
||||
$q->{sectionName}, # sectionName
|
||||
$q->{question}, # questionNumber
|
||||
$q->{questionName}, # questionName
|
||||
$q->{questionComment}, # questionComment
|
||||
$a->{id}, # answerNumber
|
||||
$a->{value}, # answerValue
|
||||
$a->{verbatim}, # answerComment
|
||||
$a->{time}, # entryDate
|
||||
$a->{isCorrect}, # isCorrect
|
||||
$a->{score}, # value (e.g. answer score)
|
||||
undef # fileStoreageId
|
||||
]
|
||||
);
|
||||
}
|
||||
|
|
@ -2602,34 +2666,6 @@ sub loadTempReportTable {
|
|||
return 1;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 www_editDefaultQuestions
|
||||
|
||||
Allows a user to edit the *site wide* default multiple choice questions displayed when adding questions to a survey.
|
||||
|
||||
=cut
|
||||
|
||||
sub www_editDefaultQuestions{
|
||||
my $self = shift;
|
||||
my $warning = shift;
|
||||
my $session = $self->session;
|
||||
my ($output);
|
||||
my $bundleId = $session->form->process("bundleId");
|
||||
|
||||
if($bundleId eq 'new'){
|
||||
|
||||
|
||||
|
||||
}
|
||||
|
||||
if($warning){$output .= "$warning";}
|
||||
# $output .= $tabForm->print;
|
||||
|
||||
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 www_downloadDefaultQuestionTypes
|
||||
|
|
@ -2642,39 +2678,12 @@ sub www_downloadDefaultQuestionTypes{
|
|||
my $self = shift;
|
||||
return $self->session->privilege->insufficient()
|
||||
if !$self->session->user->isInGroup( $self->get('groupToViewReports') );
|
||||
|
||||
my $content = to_json($self->surveyJSON->{multipleChoiceTypes});
|
||||
return $self->export( "WebGUI-Survey-DefaultQuestionTypes.json", $content );
|
||||
$self->session->http->setFilename('WebGUI-Survey-DefaultQuestionTypes.json', "application/json");
|
||||
return $content;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 www_deleteTest ( )
|
||||
|
|
|
|||
|
|
@ -543,8 +543,8 @@ sub run {
|
|||
|
||||
my $rJSON = $asset->responseJSON( undef, $mostRecentlyCompletedResponseId );
|
||||
$otherInstances->{$asset_spec} = {
|
||||
values => $rJSON->responseValuesByVariableName,
|
||||
scores => $rJSON->responseScoresByVariableName,
|
||||
values => $rJSON->responseValues( indexBy => 'variable' ),
|
||||
scores => $rJSON->responseScores( indexBy => 'variable' ),
|
||||
tags => $rJSON->tags,
|
||||
};
|
||||
$session->log->debug("Successfully looked up asset: $assetId. Repeating reval.");
|
||||
|
|
|
|||
|
|
@ -249,7 +249,7 @@ If defined, lastResponse is set to $responseIndex.
|
|||
|
||||
sub lastResponse {
|
||||
my $self = shift;
|
||||
my ($responseIndex) = validate_pos(@_, {type => SCALAR, optional => 1});
|
||||
my $responseIndex = shift;
|
||||
|
||||
if ( defined $responseIndex ) {
|
||||
$self->response->{lastResponse} = $responseIndex;
|
||||
|
|
@ -273,7 +273,7 @@ If defined, increments the number of questions by $questionsAnswered
|
|||
|
||||
sub questionsAnswered {
|
||||
my $self = shift;
|
||||
my ($questionsAnswered) = validate_pos(@_, {type => SCALAR, optional => 1});
|
||||
my $questionsAnswered = shift;
|
||||
|
||||
if ( defined $questionsAnswered ) {
|
||||
$self->response->{questionsAnswered} += $questionsAnswered;
|
||||
|
|
@ -296,8 +296,8 @@ If defined, sets $tags to the supplied hashref.
|
|||
=cut
|
||||
|
||||
sub tags {
|
||||
my $self = shift;
|
||||
my ($tags) = validate_pos(@_, {type => HASHREF, optional => 1});
|
||||
my $self = shift;
|
||||
my $tags = shift;
|
||||
|
||||
if ( $tags ) {
|
||||
$self->response->{tags} = $tags;
|
||||
|
|
@ -391,7 +391,7 @@ If defined, nextResponse is set to $responseIndex.
|
|||
|
||||
sub nextResponse {
|
||||
my $self = shift;
|
||||
my ($responseIndex) = validate_pos(@_, {type => SCALAR, optional => 1});
|
||||
my $responseIndex = shift;
|
||||
|
||||
if ( defined $responseIndex ) {
|
||||
$self->lastResponse($responseIndex - 1);
|
||||
|
|
@ -743,7 +743,7 @@ A variable name to match against all section and question variable names.
|
|||
|
||||
sub processGoto {
|
||||
my $self = shift;
|
||||
my ($goto) = validate_pos(@_, {type => SCALAR|UNDEF});
|
||||
my $goto = shift;
|
||||
|
||||
return if !$goto;
|
||||
|
||||
|
|
@ -793,13 +793,13 @@ The expression. See L<WebGUI::Asset::Wobject::Survey::ExpressionEngine> for mor
|
|||
|
||||
sub processExpression {
|
||||
my $self = shift;
|
||||
my ($expression) = validate_pos(@_, {type => SCALAR|UNDEF});
|
||||
my $expression = shift;
|
||||
|
||||
return if !$expression;
|
||||
|
||||
# Prepare the ingredients..
|
||||
my $values = $self->responseValuesByVariableName;
|
||||
my $scores = $self->responseScoresByVariableName;
|
||||
my $values = $self->responseValues( indexBy => 'variable' );
|
||||
my $scores = $self->responseScores( indexBy => 'variable' );
|
||||
my $tags = $self->tags;
|
||||
my %validTargets = map { $_ => 1 } @{$self->survey->getGotoTargets};
|
||||
|
||||
|
|
@ -867,34 +867,35 @@ sub recordedResponses{
|
|||
return $responses;
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 responseValuesByVariableName ( $options )
|
||||
=head2 responseValues ( $opts )
|
||||
|
||||
Returns a lookup table to question variable names and recorded response values.
|
||||
Returns a lookup table of recorded response values, keyed by either question variable
|
||||
or question address. Values come from the L<responses> hash.
|
||||
|
||||
Only questions with a defined variable name set are included. Values come from
|
||||
the L<responses> hash.
|
||||
Accepts the following options:
|
||||
|
||||
=head3 options
|
||||
|
||||
The following options are supported:
|
||||
|
||||
=over 3
|
||||
=over 4
|
||||
|
||||
=item * useText
|
||||
|
||||
For multiple choice questions, use the answer text instead of the recorded value
|
||||
(useful for doing [[var]] text substitution
|
||||
|
||||
=item * indexBy
|
||||
|
||||
The property to index responses by. Valid values are C<variable> (default) and C<address>.
|
||||
|
||||
When using C<variable>, only questions with a defined variable name are included in the set.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub responseValuesByVariableName {
|
||||
sub responseValues {
|
||||
my $self = shift;
|
||||
my %options = validate(@_, { useText => 0 });
|
||||
my %opts = validate(@_, { useText => 0, indexBy => { default => 'variable' } });
|
||||
|
||||
my %lookup;
|
||||
|
||||
|
|
@ -914,13 +915,16 @@ sub responseValuesByVariableName {
|
|||
# Grab the corresponding question
|
||||
my $question = $self->survey->question([@address]);
|
||||
|
||||
# Filter out questions without defined variable names
|
||||
next if !$question || !defined $question->{variable};
|
||||
# Find out what we're indexing responses by
|
||||
my $identifier
|
||||
= $opts{indexBy} eq 'variable' ? $question && $question->{variable}
|
||||
: $self->questionId($address);
|
||||
next unless $identifier;
|
||||
|
||||
my $answer = $self->survey->answer([@address]);
|
||||
|
||||
my $value = $response->{value};
|
||||
if ($options{useText}) {
|
||||
if ($opts{useText}) {
|
||||
# Test if question is a multiple choice type so we can use the answer text instead
|
||||
if($self->survey->getMultiChoiceBundle($question->{questionType})){
|
||||
my $answerText = $answer->{text};
|
||||
|
|
@ -933,16 +937,16 @@ sub responseValuesByVariableName {
|
|||
}
|
||||
}
|
||||
|
||||
# Add variable => value to our hash
|
||||
# Add identifier => value to our hash
|
||||
if (!$question->{maxAnswers} || $question->{maxAnswers} > 1) {
|
||||
push @{$lookup{$question->{variable}}}, $value;
|
||||
push @{$lookup{$identifier}}, $value;
|
||||
} else {
|
||||
$lookup{$question->{variable}} = $value;
|
||||
$lookup{$identifier} = $value;
|
||||
}
|
||||
|
||||
# For verbatims, also add verbatim value to lookup as variable + _verbatim
|
||||
# For verbatims, also add verbatim value to lookup as identifier_verbatim
|
||||
if ($answer->{verbatim}) {
|
||||
my $verbatimKey = $question->{variable} . "_verbatim";
|
||||
my $verbatimKey = "${identifier}_verbatim";
|
||||
my $verbatimValue = $response->{verbatim};
|
||||
if (!$question->{maxAnswers} || $question->{maxAnswers} > 1) {
|
||||
push @{$lookup{$verbatimKey}}, $verbatimValue;
|
||||
|
|
@ -956,21 +960,32 @@ sub responseValuesByVariableName {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 responseScoresByVariableName
|
||||
=head2 responseScores ( $opts )
|
||||
|
||||
Returns a lookup table to question variable names and recorded response values.
|
||||
Returns a lookup table of recorded response scores, keyed by either question variable
|
||||
or question address. Values come from the L<responses> hash.
|
||||
|
||||
Only questions with a defined variable name set are included. Scores come from
|
||||
the L<responses> hash.
|
||||
Accepts the following options:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * indexBy
|
||||
|
||||
The property to index responses by. Valid values are C<variable> (default) and C<address>.
|
||||
|
||||
When using C<variable>, only questions with a defined variable name are included in the set.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub responseScoresByVariableName {
|
||||
sub responseScores {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, { indexBy => { default => 'variable' } });
|
||||
|
||||
my %lookup;
|
||||
my $responses = $self->responses;
|
||||
# Process responses in id order, just to be consistent with responseValuesByVariableName
|
||||
# Process responses in id order, just to be consistent with L<responseValues>
|
||||
for my $address (sort keys %$responses) {
|
||||
next if !$address;
|
||||
my $response = $responses->{$address};
|
||||
|
|
@ -985,8 +1000,11 @@ sub responseScoresByVariableName {
|
|||
# Grab the corresponding question
|
||||
my $question = $self->survey->question([@address]);
|
||||
|
||||
# Filter out questions without defined variable names
|
||||
next if !$question || !defined $question->{variable};
|
||||
# Find out what we're indexing responses by
|
||||
my $identifier
|
||||
= $opts{indexBy} eq 'variable' ? $question && $question->{variable}
|
||||
: $self->questionId($address);
|
||||
next unless $identifier;
|
||||
|
||||
# Grab the corresponding answer
|
||||
my $answer = $self->survey->answer([@address]);
|
||||
|
|
@ -995,17 +1013,19 @@ sub responseScoresByVariableName {
|
|||
my $score = (exists $answer->{value} && length $answer->{value} > 0) ? $answer->{value} : $question->{value};
|
||||
|
||||
# Add variable => score to our hash (or add to existing score for multi-answer questions, e.g. maxAnswers != 1)
|
||||
$lookup{$question->{variable}} += $score;
|
||||
$lookup{$identifier} += $score;
|
||||
}
|
||||
|
||||
# Add section score totals
|
||||
for my $s ( @{ $self->survey->sections } ) {
|
||||
my $sVar = $s->{variable};
|
||||
next unless $sVar;
|
||||
|
||||
# N.B. Using map and grep here proved to be about twice as fast as looping over $s->{questions}
|
||||
map { $lookup{$sVar} += $lookup{ $_->{variable} } }
|
||||
grep { $_->{variable} and exists $lookup{ $_->{variable} } } @{ $s->{questions} };
|
||||
# Add section score totals (currently only implemented when index is 'variable'
|
||||
if ($opts{indexBy} eq 'variable') {
|
||||
for my $s ( @{ $self->survey->sections } ) {
|
||||
my $sVar = $s->{variable};
|
||||
next unless $sVar;
|
||||
|
||||
# N.B. Using map and grep here proved to be about twice as fast as looping over $s->{questions}
|
||||
map { $lookup{$sVar} += $lookup{ $_->{variable} } }
|
||||
grep { $_->{variable} and exists $lookup{ $_->{variable} } } @{ $s->{questions} };
|
||||
}
|
||||
}
|
||||
|
||||
return \%lookup;
|
||||
|
|
@ -1092,11 +1112,11 @@ sub nextQuestions {
|
|||
my $questionsPerPage = $self->survey->section( [ $self->nextResponseSectionIndex ] )->{questionsPerPage};
|
||||
|
||||
# Get all of the existing question responses (so that we can do Section and Question [[var]] replacements
|
||||
my $responseValuesByVariableName = $self->responseValuesByVariableName( { useText => 1 } );
|
||||
my $responseValues = $self->responseValues( { useText => 1, indexBy => 'variable' } );
|
||||
my $tags = $self->tags;
|
||||
|
||||
# Merge values and tags hashes for processing [[var]] templated text
|
||||
my %templateValues = (%$responseValuesByVariableName, %$tags);
|
||||
my %templateValues = (%$responseValues, %$tags);
|
||||
|
||||
# Do text replacement
|
||||
$section->{text} = $self->getTemplatedText($section->{text}, \%templateValues);
|
||||
|
|
@ -1207,7 +1227,7 @@ A Section Id is identical to a Section index. This method is only present for co
|
|||
|
||||
sub sectionId {
|
||||
my $self = shift;
|
||||
my ($sIndex) = validate_pos(@_, { type => SCALAR | UNDEF } );
|
||||
my $sIndex = shift;
|
||||
|
||||
return if !defined $sIndex;
|
||||
|
||||
|
|
@ -1224,7 +1244,7 @@ The id is constructed by hyphenating the Section index and Question index.
|
|||
|
||||
sub questionId {
|
||||
my $self = shift;
|
||||
my ($sIndex, $qIndex) = validate_pos(@_, { type => SCALAR | UNDEF }, { type => SCALAR | UNDEF } );
|
||||
my ($sIndex, $qIndex) = @_;
|
||||
|
||||
return if !defined $sIndex || !defined $qIndex;
|
||||
|
||||
|
|
@ -1241,7 +1261,7 @@ The id is constructed by hyphenating all three indices.
|
|||
|
||||
sub answerId {
|
||||
my $self = shift;
|
||||
my ($sIndex, $qIndex, $aIndex) = validate_pos(@_, { type => SCALAR | UNDEF }, { type => SCALAR | UNDEF }, { type => SCALAR | UNDEF } );
|
||||
my ($sIndex, $qIndex, $aIndex) = @_;
|
||||
|
||||
return if !defined $sIndex || !defined $qIndex || !defined $aIndex;
|
||||
|
||||
|
|
@ -1274,10 +1294,7 @@ This method is identical to L<WebGUI::Asset::Wobject::Survey::SurveyJSON/sIndex>
|
|||
|
||||
=cut
|
||||
|
||||
sub sIndex {
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
||||
return $address->[0];
|
||||
}
|
||||
sub sIndex { $_[0][0] }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
|
|
@ -1289,10 +1306,7 @@ This method is identical to L<WebGUI::Asset::Wobject::Survey::SurveyJSON/qIndex>
|
|||
|
||||
=cut
|
||||
|
||||
sub qIndex {
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
||||
return $address->[1];
|
||||
}
|
||||
sub qIndex { $_[0][1] }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
|
|
@ -1306,7 +1320,7 @@ This is because the third element of the L<"surveyOrder"> address array ref in i
|
|||
=cut
|
||||
|
||||
sub aIndexes {
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
||||
my $address = shift;
|
||||
|
||||
if (my $indexes = $address->[2]) {
|
||||
return @{ $indexes };
|
||||
|
|
@ -1417,64 +1431,57 @@ sub _loadSectionIntoSummary{
|
|||
}
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 returnResponseForReporting
|
||||
=head2 responseReport
|
||||
|
||||
Used to extract JSON responses for use in reporting results.
|
||||
Returns an array ref containing the current responses to the survey in a
|
||||
format that can be written to the temporary report table (see
|
||||
L<WebGUI::Asset::Wobject::Survey::loadTempReportTable>.
|
||||
|
||||
Returns an array ref containing the current responses to the survey. The array ref contains a list of hashes with the section, question,
|
||||
sectionName, questionName, questionComment, and an answer array ref. The answer array ref contains a list of hashes, with isCorrect (1 true, 0 false),
|
||||
The array ref contains a list of hashes with the section, question,
|
||||
sectionName, questionName, questionComment, and an answer array ref.
|
||||
The answer array ref contains a list of hashes, with isCorrect (1 true, 0 false),
|
||||
recorded value, and the id of the answer.
|
||||
|
||||
=cut
|
||||
|
||||
# TODO: This sub should make use of responseValuesByVariableName
|
||||
sub responseReport {
|
||||
my $self = shift;
|
||||
|
||||
sub returnResponseForReporting {
|
||||
my $self = shift;
|
||||
my @report = ();
|
||||
my @report;
|
||||
for my $address ( @{ $self->surveyOrder } ) {
|
||||
my ($sIndex, $qIndex) = (sIndex($address), qIndex($address));
|
||||
my $section = $self->survey->section( $address );
|
||||
my $question = $self->survey->question( [ $sIndex, $qIndex ] );
|
||||
my $questionId = $self->questionId($sIndex, $qIndex);
|
||||
my ( $sIndex, $qIndex ) = ( sIndex($address), qIndex($address) );
|
||||
my $section = $self->survey->section($address);
|
||||
my $question = $self->survey->question( [ $sIndex, $qIndex ] );
|
||||
my $questionId = $self->questionId( $sIndex, $qIndex );
|
||||
|
||||
# Skip if this is a Section without a Question
|
||||
if ( !defined $qIndex ) {
|
||||
next;
|
||||
}
|
||||
|
||||
my @responses;
|
||||
for my $aIndex (aIndexes($address)) {
|
||||
my $answerId = $self->answerId($sIndex, $qIndex, $aIndex);
|
||||
next unless defined $qIndex;
|
||||
|
||||
if ( $self->responses->{$answerId} ) {
|
||||
# Multi-choice answers can have multiple responses per-question,
|
||||
# so make sure we look over all answers
|
||||
my @answer_responses;
|
||||
for my $aIndex ( aIndexes($address) ) {
|
||||
my $answerId = $self->answerId( $sIndex, $qIndex, $aIndex );
|
||||
my $answer = $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] );
|
||||
|
||||
# Make a safe copy of the response
|
||||
my %response = %{$self->responses->{$answerId}};
|
||||
$response{id} = $aIndex;
|
||||
|
||||
my $answer = $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] );
|
||||
if ( $answer->{isCorrect} ) {
|
||||
$response{value}
|
||||
= $answer->{value} =~ /\w/ ? $answer->{value}
|
||||
: $question->{value}
|
||||
;
|
||||
$response{isCorrect} = 1;
|
||||
}
|
||||
else {
|
||||
$response{isCorrect} = 0;
|
||||
}
|
||||
push @responses, \%response;
|
||||
# Massage each answer response and push it onto the list
|
||||
if ( my $response = clone $self->responses->{$answerId} ) {
|
||||
$response->{isCorrect} = $answer->{isCorrect} ? 1 : 0;
|
||||
$response->{id} = $aIndex;
|
||||
$response->{score} = $answer->{value}; # N.B. answer score is consistently misnamed 'value'
|
||||
push @answer_responses, $response;
|
||||
}
|
||||
}
|
||||
push @report, {
|
||||
section => $sIndex,
|
||||
question => $qIndex,
|
||||
sectionName => $section->{variable},
|
||||
questionName => $question->{variable},
|
||||
questionComment => $self->responses->{$questionId}->{comment},
|
||||
answers => \@responses
|
||||
};
|
||||
|
||||
push @report,
|
||||
{
|
||||
section => $sIndex,
|
||||
question => $qIndex,
|
||||
sectionName => $section->{variable},
|
||||
questionName => $question->{variable},
|
||||
questionComment => $self->responses->{$questionId}->{comment},
|
||||
answers => \@answer_responses
|
||||
};
|
||||
}
|
||||
return \@report;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -266,7 +266,7 @@ Add a new answer to the indexed question inside the indexed section.
|
|||
|
||||
sub newObject {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF });
|
||||
my $address = shift;
|
||||
|
||||
# Figure out what to do by counting the number of elements in the $address array ref
|
||||
my $count = @{$address};
|
||||
|
|
@ -336,7 +336,7 @@ its answers. Should ALWAYS have two elements since we want to address a questio
|
|||
|
||||
sub getDragDropList {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF });
|
||||
my $address = shift;
|
||||
|
||||
my @data;
|
||||
for my $sIndex (0 .. $self->lastSectionIndex) {
|
||||
|
|
@ -399,7 +399,7 @@ Returns that answer.
|
|||
|
||||
sub getObject {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF });
|
||||
my $address = shift;
|
||||
|
||||
# Figure out what to do by counting the number of elements in the $address array ref
|
||||
my $count = @{$address};
|
||||
|
|
@ -433,7 +433,7 @@ sections, questions, or answers.
|
|||
|
||||
sub getEditVars {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF });
|
||||
my $address = shift;
|
||||
# Figure out what to do by counting the number of elements in the $address array ref
|
||||
my $count = @{$address};
|
||||
|
||||
|
|
@ -501,7 +501,7 @@ See L<"Address Parameter">. Specifies which question to fetch variables for.
|
|||
|
||||
sub getSectionEditVars {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF });
|
||||
my $address = shift;
|
||||
|
||||
my $section = $self->section($address);
|
||||
my %var = %{$section};
|
||||
|
|
@ -556,7 +556,7 @@ See L<"Address Parameter">. Specifies which question to fetch variables for.
|
|||
|
||||
sub getQuestionEditVars {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF });
|
||||
my $address = shift;
|
||||
|
||||
my $question = $self->question($address);
|
||||
my %var = %{$question};
|
||||
|
|
@ -618,7 +618,7 @@ See L<"Address Parameter">. Specifies which answer to fetch variables for.
|
|||
|
||||
sub getAnswerEditVars {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF });
|
||||
my $address = shift;
|
||||
|
||||
my $object = $self->answer($address);
|
||||
my %var = %{$object};
|
||||
|
|
@ -943,7 +943,7 @@ Nothing happens. It is not allowed to duplicate answers.
|
|||
|
||||
sub copy {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF });
|
||||
my $address = shift;
|
||||
|
||||
# Figure out what to do by counting the number of elements in the $address array ref
|
||||
my $count = @{$address};
|
||||
|
|
@ -1321,7 +1321,7 @@ See L<"Address Parameter">.
|
|||
|
||||
sub totalQuestions {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF, optional => 1 });
|
||||
my $address = shift;
|
||||
|
||||
if ($address) {
|
||||
return scalar @{ $self->questions($address) };
|
||||
|
|
@ -1346,7 +1346,7 @@ See L<"Address Parameter">.
|
|||
|
||||
sub totalAnswers {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF, optional => 1 });
|
||||
my $address = shift;
|
||||
|
||||
if ($address) {
|
||||
return scalar @{ $self->answers($address) };
|
||||
|
|
@ -1571,7 +1571,7 @@ See L<"Address Parameter">.
|
|||
|
||||
sub section {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
||||
my $address = shift;
|
||||
|
||||
return $self->sections->[ $address->[0] ];
|
||||
}
|
||||
|
|
@ -1599,7 +1599,7 @@ See L<"Address Parameter">. If not defined, returns all questions.
|
|||
|
||||
sub questions {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF, optional => 1});
|
||||
my $address = shift;
|
||||
|
||||
if ($address) {
|
||||
return $self->sections->[ $address->[0] ]->{questions} || [];
|
||||
|
|
@ -1622,7 +1622,7 @@ See L<"Address Parameter">.
|
|||
|
||||
sub question {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
||||
my $address = shift;
|
||||
|
||||
return $self->sections->[ $address->[0] ]->{questions}->[ $address->[1] ];
|
||||
}
|
||||
|
|
@ -1658,7 +1658,7 @@ See L<"Address Parameter">.
|
|||
|
||||
sub answers {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
||||
my $address = shift;
|
||||
|
||||
return $self->sections->[ $address->[0] ]->{questions}->[ $address->[1] ]->{answers} || [];
|
||||
}
|
||||
|
|
@ -1675,7 +1675,7 @@ See L<"Address Parameter">.
|
|||
|
||||
sub answer {
|
||||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
||||
my $address = shift;
|
||||
|
||||
return $self->sections->[ $address->[0] ]->{questions}->[ $address->[1] ]->{answers}->[ $address->[2] ];
|
||||
}
|
||||
|
|
@ -1687,10 +1687,7 @@ This method exists purely to improve code readability.
|
|||
|
||||
=cut
|
||||
|
||||
sub sIndex {
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
||||
return $address->[0];
|
||||
}
|
||||
sub sIndex { $_[0][0] }
|
||||
|
||||
=head2 qIndex ($address)
|
||||
|
||||
|
|
@ -1699,10 +1696,7 @@ This method exists purely to improve code readability.
|
|||
|
||||
=cut
|
||||
|
||||
sub qIndex {
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
||||
return $address->[1];
|
||||
}
|
||||
sub qIndex { $_[0][1] }
|
||||
|
||||
=head2 aIndex ($address)
|
||||
|
||||
|
|
@ -1711,9 +1705,6 @@ This method exists purely to improve code readability.
|
|||
|
||||
=cut
|
||||
|
||||
sub aIndex {
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
||||
return $address->[2];
|
||||
}
|
||||
sub aIndex { $_[0][2] }
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -700,7 +700,7 @@ END_WHY
|
|||
|
||||
# Check score, if asked
|
||||
if ($score && ref $score eq 'HASH') {
|
||||
my $currentScores = $rJSON->responseScoresByVariableName;
|
||||
my $currentScores = $rJSON->responseScores( indexBy => 'variable' );
|
||||
while (my ($scoreKey, $scoreValue) = each %$score) {
|
||||
my $currentScore = $currentScores->{$scoreKey};
|
||||
if ($currentScore != $scoreValue) {
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue