oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fixes to Survey reporting and performance improvements

Browse source 
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 2009-08-23 05:15:32 +00:00
parent ea51ba559e
commit 280e902c09
8 changed files with 422 additions and 273 deletions
Download patch file Download diff file Expand all files Collapse all files

1
docs/changelog/7.x.x.txt
View file

@ -1,4 +1,5 @@
7.7.19 7.7.19
- fixed Survey reporting of simple/transported results to csv/tab
- fixed #10797: searching non-ascii-characters (e.g. wiki), part 2 - fixed #10797: searching non-ascii-characters (e.g. wiki), part 2
7.7.18 7.7.18

277
lib/WebGUI/Asset/Wobject/Survey.pm
View file

@ -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 () =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 =cut
@ -2402,21 +2457,21 @@ sub www_exportSimpleResults {
return $self->session->privilege->insufficient() return $self->session->privilege->insufficient()
if !$self->session->user->isInGroup( $self->get('groupToViewReports')); if !$self->session->user->isInGroup( $self->get('groupToViewReports'));
$self->loadTempReportTable(); $self->loadTempReportTable( ignoreRevisionDate => 1 );
my $filename = $self->session->url->escape( $self->get('title') . '_results.tab' ); return $self->export(
my $content sql => 'select * from Survey_tempReport t where t.assetId=? order by t.Survey_responseId, t.order',
= $self->session->db->quickTab( sqlParams => [ $self->getId() ],
'select * from Survey_tempReport t where t.assetId=? order by t.Survey_responseId, t.order', format => scalar $self->session->form->process('format'),
[ $self->getId() ] ); name => 'simple',
return $self->export( $filename, $content ); );
} }
#------------------------------------------------------------------- #-------------------------------------------------------------------
=head2 www_exportTransposedResults () =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 =cut
@ -2425,21 +2480,22 @@ sub www_exportTransposedResults {
return $self->session->privilege->insufficient() return $self->session->privilege->insufficient()
if !$self->session->user->isInGroup( $self->get('groupToViewReports') ); if !$self->session->user->isInGroup( $self->get('groupToViewReports') );
$self->loadTempReportTable(); $self->loadTempReportTable( ignoreRevisionDate => );
my $filename = $self->session->url->escape( $self->get('title') . '_transposedResults.tab' ); return $self->export(
my $content sql => <<END_SQL,
= $self->session->db->quickTab( select r.userId, r.username, r.ipAddress, r.startDate, r.endDate, r.isComplete, t.*
'select r.userId, r.username, r.ipAddress, r.startDate, r.endDate, r.isComplete, t.*' from Survey_tempReport t
. ' from Survey_tempReport t' left join Survey_response r using(Survey_responseId)
. ' left join Survey_response r using(Survey_responseId)' where t.assetId = ?
. ' where t.assetId=?' order by r.userId, r.Survey_responseId, t.order
. ' order by r.userId, r.Survey_responseId, t.order', END_SQL
[ $self->getId() ] ); sqlParams => [ $self->getId() ],
return $self->export( $filename, $content ); format => scalar $self->session->form->process('format'),
name => 'transposed',
);
} }
#------------------------------------------------------------------- #-------------------------------------------------------------------
=head2 www_exportStructure =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 =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. 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 =cut
sub loadTempReportTable { 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 = ?', # Remove old temp report data
[ $self->getId() ] );
$self->session->db->write( 'delete from Survey_tempReport where assetId = ?', [ $self->getId() ] ); $self->session->db->write( 'delete from Survey_tempReport where assetId = ?', [ $self->getId() ] );
for my $ref (@{$refs}) {
$self->responseJSON( undef, $ref->{Survey_responseId} ); # Build the sql that will select all responses
my $count = 1; my $sql = 'select * from Survey_response where assetId = ?';
for my $q ( @{ $self->responseJSON->returnResponseForReporting() } ) {
# 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/ ) { if ( @{ $q->{answers} } == 0 and $q->{comment} =~ /\w/ ) {
$self->session->db->write( $self->session->db->write(
'insert into Survey_tempReport VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)', [ 'insert into Survey_tempReport VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)',
$self->getId(), $ref->{Survey_responseId}, $count++, $q->{section}, [ $self->getId(), # assetId
$q->{sectionName}, $q->{question}, $q->{questionName}, $q->{questionComment}, $ref->{Survey_responseId}, # Survey_responseId
undef, undef, undef, undef, $order++, # order
undef, undef, undef $q->{section},, # sectionNumber
$q->{sectionName}, # sectionName
$q->{question}, # questionNumber
$q->{questionName}, # questionName
$q->{questionComment}, # questionComment
undef,
undef,
undef,
undef,
undef,
undef,
undef
] ]
); );
next; next;
} }
for my $a ( @{ $q->{answers} } ) { for my $a ( @{ $q->{answers} } ) {
$self->session->db->write( $self->session->db->write(
'insert into Survey_tempReport VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)', [ 'insert into Survey_tempReport VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)',
$self->getId(), $ref->{Survey_responseId}, $count++, $q->{section}, [ $self->getId(), # assetId
$q->{sectionName}, $q->{question}, $q->{questionName}, $q->{questionComment}, $ref->{Survey_responseId}, # Survey_responseId
$a->{id}, $a->{value}, $a->{verbatim}, $a->{time}, $order++, # order
$a->{isCorrect}, $a->{value}, undef $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; 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 =head2 www_downloadDefaultQuestionTypes
@ -2642,39 +2678,12 @@ sub www_downloadDefaultQuestionTypes{
my $self = shift; my $self = shift;
return $self->session->privilege->insufficient() return $self->session->privilege->insufficient()
if !$self->session->user->isInGroup( $self->get('groupToViewReports') ); if !$self->session->user->isInGroup( $self->get('groupToViewReports') );
my $content = to_json($self->surveyJSON->{multipleChoiceTypes}); 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 ( ) =head2 www_deleteTest ( )

4
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
View file

@ -543,8 +543,8 @@ sub run {
my $rJSON = $asset->responseJSON( undef, $mostRecentlyCompletedResponseId ); my $rJSON = $asset->responseJSON( undef, $mostRecentlyCompletedResponseId );
$otherInstances->{$asset_spec} = { $otherInstances->{$asset_spec} = {
values => $rJSON->responseValuesByVariableName, values => $rJSON->responseValues( indexBy => 'variable' ),
scores => $rJSON->responseScoresByVariableName, scores => $rJSON->responseScores( indexBy => 'variable' ),
tags => $rJSON->tags, tags => $rJSON->tags,
}; };
$session->log->debug("Successfully looked up asset: $assetId. Repeating reval."); $session->log->debug("Successfully looked up asset: $assetId. Repeating reval.");

213
lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm
View file

@ -249,7 +249,7 @@ If defined, lastResponse is set to $responseIndex.
sub lastResponse { sub lastResponse {
my $self = shift; my $self = shift;
my ($responseIndex) = validate_pos(@_, {type => SCALAR, optional => 1}); my $responseIndex = shift;
if ( defined $responseIndex ) { if ( defined $responseIndex ) {
$self->response->{lastResponse} = $responseIndex; $self->response->{lastResponse} = $responseIndex;
@ -273,7 +273,7 @@ If defined, increments the number of questions by $questionsAnswered
sub questionsAnswered { sub questionsAnswered {
my $self = shift; my $self = shift;
my ($questionsAnswered) = validate_pos(@_, {type => SCALAR, optional => 1}); my $questionsAnswered = shift;
if ( defined $questionsAnswered ) { if ( defined $questionsAnswered ) {
$self->response->{questionsAnswered} += $questionsAnswered; $self->response->{questionsAnswered} += $questionsAnswered;
@ -296,8 +296,8 @@ If defined, sets $tags to the supplied hashref.
=cut =cut
sub tags { sub tags {
my $self = shift; my $self = shift;
my ($tags) = validate_pos(@_, {type => HASHREF, optional => 1}); my $tags = shift;
if ( $tags ) { if ( $tags ) {
$self->response->{tags} = $tags; $self->response->{tags} = $tags;
@ -391,7 +391,7 @@ If defined, nextResponse is set to $responseIndex.
sub nextResponse { sub nextResponse {
my $self = shift; my $self = shift;
my ($responseIndex) = validate_pos(@_, {type => SCALAR, optional => 1}); my $responseIndex = shift;
if ( defined $responseIndex ) { if ( defined $responseIndex ) {
$self->lastResponse($responseIndex - 1); $self->lastResponse($responseIndex - 1);
@ -743,7 +743,7 @@ A variable name to match against all section and question variable names.
sub processGoto { sub processGoto {
my $self = shift; my $self = shift;
my ($goto) = validate_pos(@_, {type => SCALAR|UNDEF}); my $goto = shift;
return if !$goto; return if !$goto;
@ -793,13 +793,13 @@ The expression. See L<WebGUI::Asset::Wobject::Survey::ExpressionEngine> for mor
sub processExpression { sub processExpression {
my $self = shift; my $self = shift;
my ($expression) = validate_pos(@_, {type => SCALAR|UNDEF}); my $expression = shift;
return if !$expression; return if !$expression;
# Prepare the ingredients.. # Prepare the ingredients..
my $values = $self->responseValuesByVariableName; my $values = $self->responseValues( indexBy => 'variable' );
my $scores = $self->responseScoresByVariableName; my $scores = $self->responseScores( indexBy => 'variable' );
my $tags = $self->tags; my $tags = $self->tags;
my %validTargets = map { $_ => 1 } @{$self->survey->getGotoTargets}; my %validTargets = map { $_ => 1 } @{$self->survey->getGotoTargets};
@ -867,34 +867,35 @@ sub recordedResponses{
return $responses; 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 Accepts the following options:
the L<responses> hash.
=head3 options =over 4
The following options are supported:
=over 3
=item * useText =item * useText
For multiple choice questions, use the answer text instead of the recorded value For multiple choice questions, use the answer text instead of the recorded value
(useful for doing [[var]] text substitution (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 =back
=cut =cut
sub responseValuesByVariableName { sub responseValues {
my $self = shift; my $self = shift;
my %options = validate(@_, { useText => 0 }); my %opts = validate(@_, { useText => 0, indexBy => { default => 'variable' } });
my %lookup; my %lookup;
@ -914,13 +915,16 @@ sub responseValuesByVariableName {
# Grab the corresponding question # Grab the corresponding question
my $question = $self->survey->question([@address]); my $question = $self->survey->question([@address]);
# Filter out questions without defined variable names # Find out what we're indexing responses by
next if !$question || !defined $question->{variable}; my $identifier
= $opts{indexBy} eq 'variable' ? $question && $question->{variable}
: $self->questionId($address);
next unless $identifier;
my $answer = $self->survey->answer([@address]); my $answer = $self->survey->answer([@address]);
my $value = $response->{value}; 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 # Test if question is a multiple choice type so we can use the answer text instead
if($self->survey->getMultiChoiceBundle($question->{questionType})){ if($self->survey->getMultiChoiceBundle($question->{questionType})){
my $answerText = $answer->{text}; 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) { if (!$question->{maxAnswers} || $question->{maxAnswers} > 1) {
push @{$lookup{$question->{variable}}}, $value; push @{$lookup{$identifier}}, $value;
} else { } 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}) { if ($answer->{verbatim}) {
my $verbatimKey = $question->{variable} . "_verbatim"; my $verbatimKey = "${identifier}_verbatim";
my $verbatimValue = $response->{verbatim}; my $verbatimValue = $response->{verbatim};
if (!$question->{maxAnswers} || $question->{maxAnswers} > 1) { if (!$question->{maxAnswers} || $question->{maxAnswers} > 1) {
push @{$lookup{$verbatimKey}}, $verbatimValue; 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 Accepts the following options:
the L<responses> hash.
=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 =cut
sub responseScoresByVariableName { sub responseScores {
my $self = shift; my $self = shift;
my %opts = validate(@_, { indexBy => { default => 'variable' } });
my %lookup; my %lookup;
my $responses = $self->responses; 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) { for my $address (sort keys %$responses) {
next if !$address; next if !$address;
my $response = $responses->{$address}; my $response = $responses->{$address};
@ -985,8 +1000,11 @@ sub responseScoresByVariableName {
# Grab the corresponding question # Grab the corresponding question
my $question = $self->survey->question([@address]); my $question = $self->survey->question([@address]);
# Filter out questions without defined variable names # Find out what we're indexing responses by
next if !$question || !defined $question->{variable}; my $identifier
= $opts{indexBy} eq 'variable' ? $question && $question->{variable}
: $self->questionId($address);
next unless $identifier;
# Grab the corresponding answer # Grab the corresponding answer
my $answer = $self->survey->answer([@address]); 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}; 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) # 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 # Add section score totals (currently only implemented when index is 'variable'
for my $s ( @{ $self->survey->sections } ) { if ($opts{indexBy} eq 'variable') {
my $sVar = $s->{variable}; for my $s ( @{ $self->survey->sections } ) {
next unless $sVar; 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} # N.B. Using map and grep here proved to be about twice as fast as looping over $s->{questions}
map { $lookup{$sVar} += $lookup{ $_->{variable} } } map { $lookup{$sVar} += $lookup{ $_->{variable} } }
grep { $_->{variable} and exists $lookup{ $_->{variable} } } @{ $s->{questions} }; grep { $_->{variable} and exists $lookup{ $_->{variable} } } @{ $s->{questions} };
}
} }
return \%lookup; return \%lookup;
@ -1092,11 +1112,11 @@ sub nextQuestions {
my $questionsPerPage = $self->survey->section( [ $self->nextResponseSectionIndex ] )->{questionsPerPage}; 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 # 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; my $tags = $self->tags;
# Merge values and tags hashes for processing [[var]] templated text # Merge values and tags hashes for processing [[var]] templated text
my %templateValues = (%$responseValuesByVariableName, %$tags); my %templateValues = (%$responseValues, %$tags);
# Do text replacement # Do text replacement
$section->{text} = $self->getTemplatedText($section->{text}, \%templateValues); $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 { sub sectionId {
my $self = shift; my $self = shift;
my ($sIndex) = validate_pos(@_, { type => SCALAR | UNDEF } ); my $sIndex = shift;
return if !defined $sIndex; return if !defined $sIndex;
@ -1224,7 +1244,7 @@ The id is constructed by hyphenating the Section index and Question index.
sub questionId { sub questionId {
my $self = shift; my $self = shift;
my ($sIndex, $qIndex) = validate_pos(@_, { type => SCALAR | UNDEF }, { type => SCALAR | UNDEF } ); my ($sIndex, $qIndex) = @_;
return if !defined $sIndex || !defined $qIndex; return if !defined $sIndex || !defined $qIndex;
@ -1241,7 +1261,7 @@ The id is constructed by hyphenating all three indices.
sub answerId { sub answerId {
my $self = shift; 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; 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 =cut
sub sIndex { sub sIndex { $_[0][0] }
my ($address) = validate_pos(@_, { type => ARRAYREF});
return $address->[0];
}
#------------------------------------------------------------------- #-------------------------------------------------------------------
@ -1289,10 +1306,7 @@ This method is identical to L<WebGUI::Asset::Wobject::Survey::SurveyJSON/qIndex>
=cut =cut
sub qIndex { sub qIndex { $_[0][1] }
my ($address) = validate_pos(@_, { type => ARRAYREF});
return $address->[1];
}
#------------------------------------------------------------------- #-------------------------------------------------------------------
@ -1306,7 +1320,7 @@ This is because the third element of the L<"surveyOrder"> address array ref in i
=cut =cut
sub aIndexes { sub aIndexes {
my ($address) = validate_pos(@_, { type => ARRAYREF}); my $address = shift;
if (my $indexes = $address->[2]) { if (my $indexes = $address->[2]) {
return @{ $indexes }; 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, 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), 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. recorded value, and the id of the answer.
=cut =cut
# TODO: This sub should make use of responseValuesByVariableName sub responseReport {
my $self = shift;
sub returnResponseForReporting { my @report;
my $self = shift;
my @report = ();
for my $address ( @{ $self->surveyOrder } ) { for my $address ( @{ $self->surveyOrder } ) {
my ($sIndex, $qIndex) = (sIndex($address), qIndex($address)); my ( $sIndex, $qIndex ) = ( sIndex($address), qIndex($address) );
my $section = $self->survey->section( $address ); my $section = $self->survey->section($address);
my $question = $self->survey->question( [ $sIndex, $qIndex ] ); my $question = $self->survey->question( [ $sIndex, $qIndex ] );
my $questionId = $self->questionId($sIndex, $qIndex); my $questionId = $self->questionId( $sIndex, $qIndex );
# Skip if this is a Section without a Question # Skip if this is a Section without a Question
if ( !defined $qIndex ) { next unless defined $qIndex;
next;
}
my @responses; # Multi-choice answers can have multiple responses per-question,
for my $aIndex (aIndexes($address)) { # so make sure we look over all answers
my $answerId = $self->answerId($sIndex, $qIndex, $aIndex); my @answer_responses;
for my $aIndex ( aIndexes($address) ) {
my $answerId = $self->answerId( $sIndex, $qIndex, $aIndex );
my $answer = $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] );
if ( $self->responses->{$answerId} ) { # Massage each answer response and push it onto the list
if ( my $response = clone $self->responses->{$answerId} ) {
# Make a safe copy of the response $response->{isCorrect} = $answer->{isCorrect} ? 1 : 0;
my %response = %{$self->responses->{$answerId}}; $response->{id} = $aIndex;
$response{id} = $aIndex; $response->{score} = $answer->{value}; # N.B. answer score is consistently misnamed 'value'
push @answer_responses, $response;
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;
} }
} }
push @report, {
section => $sIndex, push @report,
question => $qIndex, {
sectionName => $section->{variable}, section => $sIndex,
questionName => $question->{variable}, question => $qIndex,
questionComment => $self->responses->{$questionId}->{comment}, sectionName => $section->{variable},
answers => \@responses questionName => $question->{variable},
}; questionComment => $self->responses->{$questionId}->{comment},
answers => \@answer_responses
};
} }
return \@report; return \@report;
} }

45
lib/WebGUI/Asset/Wobject/Survey/SurveyJSON.pm
View file

@ -266,7 +266,7 @@ Add a new answer to the indexed question inside the indexed section.
sub newObject { sub newObject {
my $self = shift; 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 # Figure out what to do by counting the number of elements in the $address array ref
my $count = @{$address}; my $count = @{$address};
@ -336,7 +336,7 @@ its answers. Should ALWAYS have two elements since we want to address a questio
sub getDragDropList { sub getDragDropList {
my $self = shift; my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF }); my $address = shift;
my @data; my @data;
for my $sIndex (0 .. $self->lastSectionIndex) { for my $sIndex (0 .. $self->lastSectionIndex) {
@ -399,7 +399,7 @@ Returns that answer.
sub getObject { sub getObject {
my $self = shift; 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 # Figure out what to do by counting the number of elements in the $address array ref
my $count = @{$address}; my $count = @{$address};
@ -433,7 +433,7 @@ sections, questions, or answers.
sub getEditVars { sub getEditVars {
my $self = shift; 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 # Figure out what to do by counting the number of elements in the $address array ref
my $count = @{$address}; my $count = @{$address};
@ -501,7 +501,7 @@ See L<"Address Parameter">. Specifies which question to fetch variables for.
sub getSectionEditVars { sub getSectionEditVars {
my $self = shift; my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF }); my $address = shift;
my $section = $self->section($address); my $section = $self->section($address);
my %var = %{$section}; my %var = %{$section};
@ -556,7 +556,7 @@ See L<"Address Parameter">. Specifies which question to fetch variables for.
sub getQuestionEditVars { sub getQuestionEditVars {
my $self = shift; my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF }); my $address = shift;
my $question = $self->question($address); my $question = $self->question($address);
my %var = %{$question}; my %var = %{$question};
@ -618,7 +618,7 @@ See L<"Address Parameter">. Specifies which answer to fetch variables for.
sub getAnswerEditVars { sub getAnswerEditVars {
my $self = shift; my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF }); my $address = shift;
my $object = $self->answer($address); my $object = $self->answer($address);
my %var = %{$object}; my %var = %{$object};
@ -943,7 +943,7 @@ Nothing happens. It is not allowed to duplicate answers.
sub copy { sub copy {
my $self = shift; 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 # Figure out what to do by counting the number of elements in the $address array ref
my $count = @{$address}; my $count = @{$address};
@ -1321,7 +1321,7 @@ See L<"Address Parameter">.
sub totalQuestions { sub totalQuestions {
my $self = shift; my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF, optional => 1 }); my $address = shift;
if ($address) { if ($address) {
return scalar @{ $self->questions($address) }; return scalar @{ $self->questions($address) };
@ -1346,7 +1346,7 @@ See L<"Address Parameter">.
sub totalAnswers { sub totalAnswers {
my $self = shift; my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF, optional => 1 }); my $address = shift;
if ($address) { if ($address) {
return scalar @{ $self->answers($address) }; return scalar @{ $self->answers($address) };
@ -1571,7 +1571,7 @@ See L<"Address Parameter">.
sub section { sub section {
my $self = shift; my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF}); my $address = shift;
return $self->sections->[ $address->[0] ]; return $self->sections->[ $address->[0] ];
} }
@ -1599,7 +1599,7 @@ See L<"Address Parameter">. If not defined, returns all questions.
sub questions { sub questions {
my $self = shift; my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF, optional => 1}); my $address = shift;
if ($address) { if ($address) {
return $self->sections->[ $address->[0] ]->{questions} || []; return $self->sections->[ $address->[0] ]->{questions} || [];
@ -1622,7 +1622,7 @@ See L<"Address Parameter">.
sub question { sub question {
my $self = shift; my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF}); my $address = shift;
return $self->sections->[ $address->[0] ]->{questions}->[ $address->[1] ]; return $self->sections->[ $address->[0] ]->{questions}->[ $address->[1] ];
} }
@ -1658,7 +1658,7 @@ See L<"Address Parameter">.
sub answers { sub answers {
my $self = shift; my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF}); my $address = shift;
return $self->sections->[ $address->[0] ]->{questions}->[ $address->[1] ]->{answers} || []; return $self->sections->[ $address->[0] ]->{questions}->[ $address->[1] ]->{answers} || [];
} }
@ -1675,7 +1675,7 @@ See L<"Address Parameter">.
sub answer { sub answer {
my $self = shift; my $self = shift;
my ($address) = validate_pos(@_, { type => ARRAYREF}); my $address = shift;
return $self->sections->[ $address->[0] ]->{questions}->[ $address->[1] ]->{answers}->[ $address->[2] ]; return $self->sections->[ $address->[0] ]->{questions}->[ $address->[1] ]->{answers}->[ $address->[2] ];
} }
@ -1687,10 +1687,7 @@ This method exists purely to improve code readability.
=cut =cut
sub sIndex { sub sIndex { $_[0][0] }
my ($address) = validate_pos(@_, { type => ARRAYREF});
return $address->[0];
}
=head2 qIndex ($address) =head2 qIndex ($address)
@ -1699,10 +1696,7 @@ This method exists purely to improve code readability.
=cut =cut
sub qIndex { sub qIndex { $_[0][1] }
my ($address) = validate_pos(@_, { type => ARRAYREF});
return $address->[1];
}
=head2 aIndex ($address) =head2 aIndex ($address)
@ -1711,9 +1705,6 @@ This method exists purely to improve code readability.
=cut =cut
sub aIndex { sub aIndex { $_[0][2] }
my ($address) = validate_pos(@_, { type => ARRAYREF});
return $address->[2];
}
1; 1;

2
lib/WebGUI/Asset/Wobject/Survey/Test.pm
View file

@ -700,7 +700,7 @@ END_WHY
# Check score, if asked # Check score, if asked
if ($score && ref $score eq 'HASH') { if ($score && ref $score eq 'HASH') {
my $currentScores = $rJSON->responseScoresByVariableName; my $currentScores = $rJSON->responseScores( indexBy => 'variable' );
while (my ($scoreKey, $scoreValue) = each %$score) { while (my ($scoreKey, $scoreValue) = each %$score) {
my $currentScore = $currentScores->{$scoreKey}; my $currentScore = $currentScores->{$scoreKey};
if ($currentScore != $scoreValue) { if ($currentScore != $scoreValue) {

141
t/Asset/Wobject/Survey/Reports.t Normal file
View file

@ -0,0 +1,141 @@
# Tests WebGUI::Asset::Wobject::Survey Reporting
#
#
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../../../lib";
use Test::More;
use Test::Deep;
use Data::Dumper;
use WebGUI::Test; # Must use this before any other WebGUI modules
use WebGUI::Session;
WebGUI::Error->Trace(1); # Turn on tracing of uncaught Exception::Class exceptions
#----------------------------------------------------------------------------
# Init
my $session = WebGUI::Test->session;
#----------------------------------------------------------------------------
# Tests
my $tests = 2;
plan tests => $tests + 1;
#----------------------------------------------------------------------------
# put your tests here
my $usedOk = use_ok('WebGUI::Asset::Wobject::Survey');
my ($survey);
# Returns the contents of the Survey_tempReport table
sub getAll { $session->db->buildArrayRefOfHashRefs('select * from Survey_tempReport where assetId = ?', [$survey->getId]) }
SKIP: {
skip $tests, "Unable to load Survey" unless $usedOk;
my $user = WebGUI::User->new( $session, 'new' );
WebGUI::Test->usersToDelete($user);
my $import_node = WebGUI::Asset->getImportNode($session);
# Create a Survey
$survey = $import_node->addChild( { className => 'WebGUI::Asset::Wobject::Survey', } );
isa_ok($survey, 'WebGUI::Asset::Wobject::Survey');
my $sJSON = $survey->surveyJSON;
# Load bare-bones survey, containing a single section (S0)
$sJSON->update([0], { variable => 'S0' });
# Add 2 questions to S0
$sJSON->newObject([0]); # S0Q0
$sJSON->update([0,0], { variable => 'S0Q0', questionType => 'Yes/No' });
# Change the Yes/No default properties
my $yesProps = {
value => 10, # e.g. score
recordedAnswer => 'Yessir',
isCorrect => 0,
verbatim => 1,
};
my $noProps = {
value => 20, # e.g. score
recordedAnswer => 'Nosir',
isCorrect => 1,
verbatim => 1,
};
$sJSON->update([0,0,0], $yesProps);
$sJSON->update([0,0,1], $noProps);
$sJSON->newObject([0]); # S0Q1
$sJSON->update([0,1], { variable => 'S0Q1', questionType => 'Yes/No' });
$sJSON->update([0,1,0], $yesProps);
$sJSON->update([0,1,1], $noProps);
# Add a new section (S1)
$sJSON->newObject([]); # S1
$sJSON->update([1], { variable => 'S1' });
# Add 2 questions to S1
$sJSON->newObject([1]); # S1Q0
$sJSON->update([1,0], { variable => 'S1Q0' });
$sJSON->newObject([1]); # S1Q1
$sJSON->update([1,1], { variable => 'S1Q1' });
$survey->persistSurveyJSON;
# Now start a response as the test user
$session->user( { user => $user } );
my $responseId = $survey->responseId;
$survey->recordResponses( {
'0-0-0' => 'Y',
'0-0comment' => 'I answered S0Q0',
'0-0-0verbatim' => '..and chose Y',
'0-1-1' => 'N',
'0-1comment' => 'I answered S0Q1',
'0-1-1verbatim' => '..and chose N',
} );
$survey->loadTempReportTable;
cmp_deeply(getAll, [
superhashof({
assetId => $survey->getId,
Survey_responseId => $responseId,
order => 1,
sectionNumber => 0,
sectionName => 'S0',
questionNumber => 0,
questionName => 'S0Q0',
questionComment => 'I answered S0Q0',
answerNumber => 0,
answerValue => 'Yessir', # e.g. recorded value
answerComment => '..and chose Y',
isCorrect => 0,
value => 10, # e.g. score
}),
superhashof({
assetId => $survey->getId,
Survey_responseId => $responseId,
order => 2,
sectionNumber => 0,
sectionName => 'S0',
questionNumber => 1,
questionName => 'S0Q1',
questionComment => 'I answered S0Q1',
answerNumber => 1,
answerValue => 'Nosir', # e.g. recorded value
answerComment => '..and chose N',
isCorrect => 1,
value => 20, # e.g. score
})]);
}
#----------------------------------------------------------------------------
# Cleanup
END {
$survey->purge() if $survey;
my $versionTag = WebGUI::VersionTag->getWorking( $session, 1 );
$versionTag->rollback() if $versionTag;
}

6
t/Asset/Wobject/Survey/ResponseJSON.t
View file

@ -309,7 +309,7 @@ cmp_deeply($rJSON->surveyOrderIndex(), $expect, 'surveyOrderIndex');
#################################################### ####################################################
# #
# responseScoresByVariableName # responseScores
# #
#################################################### ####################################################
@ -321,14 +321,14 @@ $rJSON->survey->question([1,0])->{variable} = 's1q0';
$rJSON->survey->question([1,1])->{variable} = 's1q1'; $rJSON->survey->question([1,1])->{variable} = 's1q1';
$rJSON->survey->answer([1,0,0])->{value} = 100; # set answer score $rJSON->survey->answer([1,0,0])->{value} = 100; # set answer score
$rJSON->survey->answer([1,1,0])->{value} = 200; # set answer score $rJSON->survey->answer([1,1,0])->{value} = 200; # set answer score
cmp_deeply($rJSON->responseScoresByVariableName, {}, 'scores initially empty'); cmp_deeply($rJSON->responseScores, {}, 'scores initially empty');
$rJSON->lastResponse(2); $rJSON->lastResponse(2);
$rJSON->recordResponses({ $rJSON->recordResponses({
'1-0-0' => 'My chosen answer', '1-0-0' => 'My chosen answer',
'1-1-0' => 'My chosen answer', '1-1-0' => 'My chosen answer',
}); });
cmp_deeply($rJSON->responseScoresByVariableName, { s1q0 => 100, s1q1 => 200, s1 => 300}, 'scores now reflect q answers and section totals'); cmp_deeply($rJSON->responseScores(indexBy => 'variable'), { s1q0 => 100, s1q1 => 200, s1 => 300}, 'scores now reflect q answers and section totals');
#################################################### ####################################################
# #