diff --git a/docs/changelog/7.x.x.txt b/docs/changelog/7.x.x.txt index fb631af79..a396c80b8 100644 --- a/docs/changelog/7.x.x.txt +++ b/docs/changelog/7.x.x.txt @@ -1,4 +1,5 @@ 7.7.19 + - fixed Survey reporting of simple/transported results to csv/tab - fixed #10797: searching non-ascii-characters (e.g. wiki), part 2 7.7.18 diff --git a/lib/WebGUI/Asset/Wobject/Survey.pm b/lib/WebGUI/Asset/Wobject/Survey.pm index d0f3b0e52..c13acdbb8 100644 --- a/lib/WebGUI/Asset/Wobject/Survey.pm +++ b/lib/WebGUI/Asset/Wobject/Survey.pm @@ -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 or C + +=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 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 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 => < [ $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 ( ) diff --git a/lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm b/lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm index 42c6cb516..17abd5ed5 100644 --- a/lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm +++ b/lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm @@ -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."); diff --git a/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm b/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm index 3c68b4b92..6a2b5ccd7 100644 --- a/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm +++ b/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm @@ -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 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 hash. -Only questions with a defined variable name set are included. Values come from -the L 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 (default) and C
. + +When using C, 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 hash. -Only questions with a defined variable name set are included. Scores come from -the L hash. +Accepts the following options: + +=over 4 + +=item * indexBy + +The property to index responses by. Valid values are C (default) and C
. + +When using C, 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 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 =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 =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. -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; } diff --git a/lib/WebGUI/Asset/Wobject/Survey/SurveyJSON.pm b/lib/WebGUI/Asset/Wobject/Survey/SurveyJSON.pm index 296548101..bb139e387 100644 --- a/lib/WebGUI/Asset/Wobject/Survey/SurveyJSON.pm +++ b/lib/WebGUI/Asset/Wobject/Survey/SurveyJSON.pm @@ -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; diff --git a/lib/WebGUI/Asset/Wobject/Survey/Test.pm b/lib/WebGUI/Asset/Wobject/Survey/Test.pm index 83981a432..1a0ccc32d 100644 --- a/lib/WebGUI/Asset/Wobject/Survey/Test.pm +++ b/lib/WebGUI/Asset/Wobject/Survey/Test.pm @@ -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) { diff --git a/t/Asset/Wobject/Survey/Reports.t b/t/Asset/Wobject/Survey/Reports.t new file mode 100644 index 000000000..3778d2de3 --- /dev/null +++ b/t/Asset/Wobject/Survey/Reports.t @@ -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; +} diff --git a/t/Asset/Wobject/Survey/ResponseJSON.t b/t/Asset/Wobject/Survey/ResponseJSON.t index e27bd0afc..506a46651 100644 --- a/t/Asset/Wobject/Survey/ResponseJSON.t +++ b/t/Asset/Wobject/Survey/ResponseJSON.t @@ -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->answer([1,0,0])->{value} = 100; # 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->recordResponses({ '1-0-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'); #################################################### #