8b34dc79ee
WebGUI::Asset::Wobject::Survey::ResponseJSON::responseValues was returning empty result for indexBy => 'addresses'
1611 lines
52 KiB
Perl
1611 lines
52 KiB
Perl
package WebGUI::Asset::Wobject::Survey::ResponseJSON;
|
|
|
|
=head1 LEGAL
|
|
|
|
-------------------------------------------------------------------
|
|
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
|
-------------------------------------------------------------------
|
|
Please read the legal notices (docs/legal.txt) and the license
|
|
(docs/license.txt) that came with this distribution before using
|
|
this software.
|
|
-------------------------------------------------------------------
|
|
http://www.plainblack.com info@plainblack.com
|
|
-------------------------------------------------------------------
|
|
|
|
=head1 NAME
|
|
|
|
Package WebGUI::Asset::Wobject::Survey::ResponseJSON
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Helper class for WebGUI::Asset::Wobject::Survey. The class deals with both a
|
|
"reponse" in the sense of an overall Survey response, and also "response" in
|
|
the sense of a single Question response (which is closely related to an Answer but
|
|
not quite the same).
|
|
|
|
As a whole, this class represents the complete state of a user's response to a Survey instance.
|
|
|
|
At the heart of this class is a perl hash that can be serialized
|
|
as JSON to the database to allow for storage and retrieval of the complete state
|
|
of a survey response.
|
|
|
|
Survey instances that allow users to record multiple responses will persist multiple
|
|
instances of this class to the database (one per distinct user response).
|
|
|
|
Data stored in this object include the order in which questions and answers are
|
|
presented to the user (L<"surveyOrder">), a snapshot of all completed questions
|
|
from the user (L<"responses">), the most recently answered question (L<"lastResponse">) and the
|
|
number of questions answered (L<"questionsAnswered">).
|
|
|
|
This package is not intended to be used by any other Asset in WebGUI.
|
|
|
|
=cut
|
|
|
|
use strict;
|
|
use JSON;
|
|
use Params::Validate qw(:all);
|
|
use List::Util qw(shuffle);
|
|
use Clone qw/clone/;
|
|
use Safe;
|
|
use WebGUI::Asset::Wobject::Survey::ExpressionEngine;
|
|
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 new ( $survey, $json )
|
|
|
|
Object constructor.
|
|
|
|
=head3 $survey
|
|
|
|
A L<WebGUI::Asset::Wobject::Survey::SurveyJSON> object that represents the current
|
|
survey.
|
|
|
|
=head3 $json
|
|
|
|
A JSON string used to construct a new Perl object. The string should represent
|
|
a JSON hash made up of L<"surveyOrder">, L<"responses">, L<"lastResponse">
|
|
and L<"questionsAnswered"> keys, with appropriate values.
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my ($survey, $json) = validate_pos(@_, {isa => 'WebGUI::Asset::Wobject::Survey::SurveyJSON' }, { type => SCALAR | UNDEF, optional => 1});
|
|
|
|
# Load json object if given..
|
|
my $jsonData = $json ? from_json($json) : {};
|
|
|
|
# Create skeleton object..
|
|
my $self = {
|
|
_survey => $survey,
|
|
_session => $survey->session,
|
|
# _response property set by call to reset()
|
|
};
|
|
|
|
bless $self, $class;
|
|
$self->reset({ data => $jsonData });
|
|
}
|
|
|
|
=head2 reset
|
|
|
|
Reset all response data in this object (e.g. re-init the _response property)
|
|
|
|
=cut
|
|
|
|
sub reset {
|
|
my $self = shift;
|
|
my (%opts) = validate(@_, { data => { type => HASHREF, default => {} }, preserveSurveyOrder => 0 } );
|
|
|
|
my $data = $opts{data};
|
|
|
|
# Access these via the private hash var so that we don't inadvertantly trigger initSurveyOrder
|
|
my $oldSurveyOrder = $self->{_response}{surveyOrder};
|
|
my $oldSurveyOrderLookup = $self->{_response}{surveyOrderLookup};
|
|
|
|
$self->{_response} = {
|
|
# Response hash defaults..
|
|
responses => {},
|
|
lastResponse => -1,
|
|
questionsAnswered => 0,
|
|
surveyOrder => undef,
|
|
tags => {},
|
|
};
|
|
|
|
# And then data overrides (via a hash slice)
|
|
@{$self->{_response}}{keys %{$data}} = values %{$data};
|
|
|
|
if ($opts{preserveSurveyOrder}) {
|
|
$self->{_response}{surveyOrder} = $oldSurveyOrder;
|
|
$self->{_response}{surveyOrderLookup} = $oldSurveyOrderLookup;
|
|
}
|
|
|
|
# If first section is logical, process it immediately
|
|
$self->checkForLogicalSection;
|
|
|
|
return $self;
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
|
|
=head2 initSurveyOrder
|
|
|
|
Computes and stores the order of Sections, Questions and Aswers for this Survey.
|
|
See L<"surveyOrder">. You normally don't need to call this, as L<"surveyOrder"> will
|
|
call it for you the first time it is used.
|
|
|
|
Also builds a lookup table for surveyOrder index, for performance reasons.
|
|
|
|
Questions and Answers that are set to be randomized are shuffled into a random order.
|
|
|
|
=cut
|
|
|
|
sub initSurveyOrder {
|
|
my $self = shift;
|
|
|
|
# Build a lookup table as we go
|
|
my %lookup;
|
|
|
|
# Order Questions in each Section
|
|
my @surveyOrder;
|
|
my $surveyOrderIndex = 0;
|
|
for my $sIndex ( 0 .. $self->survey->lastSectionIndex ) {
|
|
my $s = $self->survey->section( [$sIndex] );
|
|
|
|
if (my $variable = $s->{variable}) {
|
|
$lookup{$variable} = $surveyOrderIndex if !exists $lookup{$variable};
|
|
}
|
|
|
|
# Randomize Questions if required..
|
|
my @qOrder;
|
|
if ( $s->{randomizeQuestions} ) {
|
|
@qOrder = shuffle 0 .. $self->survey->lastQuestionIndex( [$sIndex] );
|
|
}
|
|
else {
|
|
@qOrder = ( 0 .. $self->survey->lastQuestionIndex( [$sIndex] ) );
|
|
}
|
|
|
|
# Order Answers in each Question
|
|
for my $qIndex (@qOrder) {
|
|
|
|
my $question = $self->survey->question( [ $sIndex, $qIndex ] );
|
|
if (my $variable = $question->{variable}) {
|
|
$lookup{$variable} = $surveyOrderIndex if !exists $lookup{$variable};
|
|
}
|
|
|
|
# Randomize Answers if required..
|
|
my @aOrder;
|
|
if ( $question->{randomizeAnswers} ) {
|
|
@aOrder = shuffle 0 .. $self->survey->lastAnswerIndex( [ $sIndex, $qIndex ] );
|
|
}
|
|
else {
|
|
@aOrder = ( 0 .. $self->survey->lastAnswerIndex( [ $sIndex, $qIndex ] ) );
|
|
}
|
|
push @surveyOrder, [ $sIndex, $qIndex, \@aOrder ];
|
|
$surveyOrderIndex++; # Increment each time an item is pushed onto @surveyOrder
|
|
}
|
|
|
|
# If Section had no Questions, make sure it is still added to @surveyOrder
|
|
if ( !@qOrder ) {
|
|
push @surveyOrder, [$sIndex];
|
|
$surveyOrderIndex++; # Increment each time an item is pushed onto @surveyOrder
|
|
}
|
|
}
|
|
$self->response->{surveyOrder} = \@surveyOrder;
|
|
$self->response->{surveyOrderLookup} = \%lookup;
|
|
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 session
|
|
|
|
Accessor method for the WebGUI::Session reference
|
|
|
|
=cut
|
|
|
|
sub session {
|
|
my $self = shift;
|
|
return $self->{_session};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 freeze
|
|
|
|
Serializes the internal perl hash representing the Response to a JSON string
|
|
|
|
To reduce json serialization time and db bloat, we only serialize the bare essentials
|
|
|
|
=cut
|
|
|
|
sub freeze {
|
|
my $self = shift;
|
|
|
|
# These are the only properties of the response hash that we serialize:
|
|
my @props = qw(responses lastResponse questionsAnswered tags);
|
|
my %serialize;
|
|
@serialize{@props} = @{$self->response}{@props};
|
|
return to_json(\%serialize);
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 lastResponse ([ $responseIndex ])
|
|
|
|
Mutator. The lastResponse property represents the surveyOrder index of the most recent item shown.
|
|
|
|
This method returns (and optionally sets) the value of lastResponse.
|
|
|
|
You may want to call L<checkForLogicalSection> after modifying this so that
|
|
any logical section you land in gets immediately processed.
|
|
|
|
=head3 $responseIndex (optional)
|
|
|
|
If defined, lastResponse is set to $responseIndex.
|
|
|
|
=cut
|
|
|
|
sub lastResponse {
|
|
my $self = shift;
|
|
my $responseIndex = shift;
|
|
|
|
if ( defined $responseIndex ) {
|
|
$self->response->{lastResponse} = $responseIndex;
|
|
}
|
|
|
|
return $self->response->{lastResponse};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 questionsAnswered ([ $questionsAnswered ])
|
|
|
|
Mutator for the number of questions answered.
|
|
Returns (and optionally sets) the value of questionsAnswered.
|
|
|
|
=head3 $questionsAnswered (optional)
|
|
|
|
If defined, increments the number of questions by $questionsAnswered
|
|
|
|
=cut
|
|
|
|
sub questionsAnswered {
|
|
my $self = shift;
|
|
my $questionsAnswered = shift;
|
|
|
|
if ( defined $questionsAnswered ) {
|
|
$self->response->{questionsAnswered} += $questionsAnswered;
|
|
}
|
|
|
|
return $self->response->{questionsAnswered};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 tags ([ $tags ])
|
|
|
|
Mutator for the tags that have been applied to the response.
|
|
Returns (and optionally sets) the value of tags.
|
|
|
|
=head3 $tags (optional)
|
|
|
|
If defined, sets $tags to the supplied hashref.
|
|
|
|
=cut
|
|
|
|
sub tags {
|
|
my $self = shift;
|
|
my $tags = shift;
|
|
|
|
if ( $tags ) {
|
|
$self->response->{tags} = $tags;
|
|
}
|
|
|
|
return $self->response->{tags};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 surveyOrder
|
|
|
|
Accessor. Initialized on first access via L<"initSurveyOrder">.
|
|
|
|
This data strucutre represents the list of items that are shown to the user, in the order
|
|
that they will be shown (ignoring jumps and jump expressions).
|
|
|
|
Typically each item will correspond to a question, and contains enough information to look
|
|
up both the corresponding section and all contained answers (if any).
|
|
|
|
Empty sections also appear in the list.
|
|
|
|
Each element of the array is an address, similar in structure to
|
|
L<WebGUI::Asset::Wobject::Survey::SurveyJSON/Address Parameter>,
|
|
except that instead of an answerIndex in the third slot, we have a sub-array of all contained answer indicies.
|
|
|
|
[ $sectionIndex, $questionIndex, [ $answerIndex1, $answerIndex2, ....]
|
|
|
|
By making use of L<WebGUI::Asset::Wobject::Survey::SurveyJSON> methods which expect address params as
|
|
arguments, you can access Section/Question/Answer items in order by iterating over surveyOrder.
|
|
|
|
For example:
|
|
|
|
# Access sections in order..
|
|
for my $address (@{ $self->surveyOrder }) {
|
|
my $section = $self->survey->section( $address );
|
|
# etc..
|
|
}
|
|
|
|
=cut
|
|
|
|
sub surveyOrder {
|
|
my $self = shift;
|
|
|
|
if (!defined $self->response->{surveyOrder}) {
|
|
$self->initSurveyOrder();
|
|
}
|
|
|
|
return $self->response->{surveyOrder};
|
|
}
|
|
|
|
=head2 surveyOrderIndex ($variable)
|
|
|
|
Looks up the surveyOrder index of Section/Question via variable name
|
|
|
|
Uses the surveyOrderLookup table, which gets lazily built if it doesn't exist
|
|
|
|
=cut
|
|
|
|
sub surveyOrderIndex {
|
|
my $self = shift;
|
|
my $variable = shift;
|
|
|
|
if (!defined $self->response->{surveyOrderLookup}) {
|
|
$self->initSurveyOrder();
|
|
}
|
|
|
|
if ($variable) {
|
|
return $self->response->{surveyOrderLookup}{$variable};
|
|
} else {
|
|
return clone $self->response->{surveyOrderLookup};
|
|
}
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 nextResponse ([ $responseIndex ])
|
|
|
|
Mutator. The index of the next item that should be shown to the user,
|
|
that is, the index of the next item in the L<"surveyOrder"> array,
|
|
e.g. L<"lastResponse"> + 1.
|
|
|
|
You may want to call L<checkForLogicalSection> after modifying this so that
|
|
any logical section you land in gets immediately processed.
|
|
|
|
=head3 $responseIndex (optional)
|
|
|
|
If defined, nextResponse is set to $responseIndex.
|
|
|
|
=cut
|
|
|
|
sub nextResponse {
|
|
my $self = shift;
|
|
my $responseIndex = shift;
|
|
|
|
if ( defined $responseIndex ) {
|
|
$self->lastResponse($responseIndex - 1);
|
|
}
|
|
|
|
return $self->lastResponse() + 1
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 nextResponseSectionIndex
|
|
|
|
Returns the Section index of the next item that should be
|
|
shown to the user, that is, the next item in the L<"surveyOrder"> array
|
|
relative to L<"lastResponse">.
|
|
|
|
We go to the effort of calling this property "nextResponseSectionIndex"
|
|
rather than just "nextSectionIndex" to emphasize that this property is
|
|
distinct from the "next" section index in the Survey. For example, in
|
|
a Section with multiple Questions, the value of nextResponseSectionIndex
|
|
will be the same value (the current section index) for all Questions
|
|
except the last Question.
|
|
|
|
=cut
|
|
|
|
sub nextResponseSectionIndex {
|
|
my $self = shift;
|
|
return undef if $self->surveyEnd();
|
|
return $self->surveyOrder->[ $self->nextResponse ]->[0];
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 nextResponseSection
|
|
|
|
Returns the Section corresponding to the next item that should be
|
|
shown to the user, that is, the next item in the L<"surveyOrder"> array
|
|
relative to L<"lastResponse">.
|
|
|
|
As with L<"nextResponseSectionIndex">, we go to the effort of calling this property "nextResponseSection"
|
|
rather than just "nextSection" to emphasize that this property is
|
|
distinct from the "next" section in the Survey.
|
|
|
|
=cut
|
|
|
|
sub nextResponseSection {
|
|
my $self = shift;
|
|
|
|
return {} if $self->surveyEnd();
|
|
return $self->survey->section( [ $self->nextResponseSectionIndex ] );
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 lastResponseSectionIndex
|
|
|
|
Returns the Section index of the last item that was shown to the user,
|
|
based on the L<"surveyOrder"> array and L<"lastResponse">.
|
|
|
|
=cut
|
|
|
|
sub lastResponseSectionIndex {
|
|
my $self = shift;
|
|
return $self->surveyOrder->[ $self->lastResponse ]->[0];
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 recordResponses ($responses)
|
|
|
|
Processes and records submitted survey responses in the L<"responses"> data structure.
|
|
Does terminal handling, and branch processing, and advances the L<"lastResponse"> index
|
|
if all required questions have been answered.
|
|
|
|
=head3 $responses
|
|
|
|
A hash ref of submitted form param data. Each element should look like:
|
|
|
|
{
|
|
"questionId-comment" => "question comment",
|
|
"answerId" => "answer",
|
|
"answerId-verbatim" => "answer verbatim",
|
|
}
|
|
|
|
See L<"questionId"> and L<"answerId">.
|
|
|
|
=head3 Terminal, goto and gotoExpression processing
|
|
|
|
Gotos are processed first, followed by gotoExpressions, and finally terminals.
|
|
On a page with the following items:
|
|
Section 1
|
|
Question 1.1
|
|
Answer 1.1.1
|
|
Answer 1.1.2
|
|
Question 1.2
|
|
Answer 1.2.1
|
|
..
|
|
|
|
the precedence order is inside-out, in order of questions displayed, e.g.
|
|
|
|
Answer 1.1.1
|
|
Answer 1.1.2
|
|
Question 1.1
|
|
Answer 1.2.1
|
|
Question 1.2
|
|
Section 1
|
|
|
|
The first to trigger a jump short-circuits the process, meaning that subsequent items are not attempted.
|
|
|
|
For Sections with questions spread out over several pages, Section-level actions are only performed on the final page of the Section.
|
|
|
|
=cut
|
|
|
|
sub recordResponses {
|
|
my $self = shift;
|
|
my ($responses) = validate_pos( @_, { type => HASHREF } );
|
|
|
|
# Build a lookup table of non-multiple choice question types
|
|
my %specialQTypes = map { $_ => 1 } @{ $self->survey->specialQuestionTypes };
|
|
|
|
# We want to record responses against the "next" response section and questions, since these are
|
|
# the items that have just been displayed to the user.
|
|
my $section = $self->nextResponseSection();
|
|
my $sId = $self->nextResponseSectionIndex(); # make note of the section id prior to recording any responses
|
|
|
|
# Process responses by looping over expected questions in survey order
|
|
my @questions = $self->nextQuestions();
|
|
my %newResponse;
|
|
my $allQsValid = 1;
|
|
my %validAnswers;
|
|
for my $question (@questions) {
|
|
my $aValid = 0;
|
|
my $qId = $question->{id};
|
|
|
|
my $comment = $responses->{ "${qId}comment" };
|
|
if (defined $comment && length $comment) {
|
|
$newResponse{ $qId }->{comment} = $comment;
|
|
}
|
|
|
|
for my $answer ( @{ $question->{answers} } ) {
|
|
my $aId = $answer->{id};
|
|
my $recordedAnswer = $responses->{ $aId };
|
|
my $questionType = $question->{questionType};
|
|
|
|
# Server-side Validation and storing of extra data for special q types goes here
|
|
# Any answer that fails validation should be skipped with 'next'
|
|
|
|
if ( $questionType eq 'Country' ) {
|
|
# Must be a valid country
|
|
if (!grep { $_ eq $recordedAnswer } WebGUI::Form::Country->getCountries) {
|
|
$self->session->log->debug("Invalid $questionType: $recordedAnswer");
|
|
next;
|
|
}
|
|
}
|
|
# elsif ( $questionType eq 'Date' ) {
|
|
# # Accept any date input until we get per-question validation options
|
|
# if ($recordedAnswer !~ m|^\d{4}/\d{1,2}/\d{1,2}$|) {
|
|
# $self->session->log->debug("Invalid $questionType: $recordedAnswer");
|
|
# next;
|
|
# }
|
|
# }
|
|
elsif ( $questionType eq 'Number' || $questionType eq 'Slider' ) {
|
|
if ( $answer->{max} =~ /\d/ and $recordedAnswer > $answer->{max} ) {
|
|
$self->session->log->debug("Invalid $questionType: $recordedAnswer");
|
|
next;
|
|
}
|
|
elsif ( $answer->{min} =~ /\d/ and $recordedAnswer < $answer->{min} ) {
|
|
$self->session->log->debug("Invalid $questionType: $recordedAnswer");
|
|
next;
|
|
}
|
|
}
|
|
elsif ( $questionType eq 'Year Month' ) {
|
|
# store year and month as "YYYY Month"
|
|
$recordedAnswer = $responses->{ "$aId-year" } . " " . $responses->{ "$aId-month" };
|
|
}
|
|
else {
|
|
# In the case of a mc question, only selected answers will have a defined recordedAnswer
|
|
# Thus we skip any answers where recordedAnswer is not defined
|
|
if (!defined $recordedAnswer || $recordedAnswer !~ /\S/) {
|
|
$self->session->log->debug("Invalid $questionType: $recordedAnswer");
|
|
next;
|
|
}
|
|
}
|
|
|
|
# If we reach here, answer validated ok
|
|
$aValid = 1;
|
|
$validAnswers{$aId} = 1;
|
|
|
|
# Now, decide what to record. For multi-choice questions, use recordedAnswer.
|
|
# Otherwise, we use the (raw) submitted response (e.g. text input, date input etc..)
|
|
$newResponse{ $aId } = {
|
|
value => $specialQTypes{ $questionType } ? $recordedAnswer : $answer->{recordedAnswer},
|
|
time => time,
|
|
};
|
|
|
|
# Only record verbatim if answer is marked verbatim
|
|
my $verbatim = $responses->{ "${aId}verbatim" };
|
|
if ($answer->{verbatim} && defined $verbatim && length $verbatim) {
|
|
$newResponse{ $aId }{verbatim} = $verbatim;
|
|
}
|
|
}
|
|
|
|
# Check if a required Question was skipped
|
|
$allQsValid = 0 if $question->{required} && !$aValid;
|
|
|
|
# If question was answered, increment the questionsAnswered count..
|
|
$self->questionsAnswered(+1) if $aValid;
|
|
}
|
|
|
|
# Stop here on validation errors
|
|
if ( !$allQsValid ) {
|
|
$self->session->log->debug("One or more questions failed validation");
|
|
return;
|
|
}
|
|
|
|
# Add newResponse to the overall response (via a hash slice)
|
|
@{$self->responses}{keys %newResponse} = values %newResponse;
|
|
|
|
# Now that the response has been recorded, increment nextResponse
|
|
# N.B. This can be overwritten by goto and gotoExpressions, below.
|
|
# (we give them a chance to run before processing logical sections)
|
|
# Normally we move forward by the number of questions answered, but if
|
|
# the section has no questions we still move forward by 1
|
|
$self->nextResponse( $self->nextResponse + ( @questions || 1 ) );
|
|
|
|
# Now that the response has been added, loop over the questions a second time
|
|
# to process goto, gotoExpression, and terminalUrls.
|
|
#
|
|
# We are only dealing with a single section. On a page with:
|
|
#
|
|
# Section 1
|
|
# Question 1.1
|
|
# Answer 1.1.1
|
|
# Answer 1.1.2
|
|
# Question 1.2
|
|
# Answer 1.2.1
|
|
# ..
|
|
#
|
|
# the precedence order is inside-out, in order of questions displayed, e.g.
|
|
#
|
|
# Answer 1.1.1
|
|
# Answer 1.1.2
|
|
# Question 1.1
|
|
# Answer 1.2.1
|
|
# Question 1.2
|
|
# Section 1
|
|
# ..
|
|
for my $question (@questions) {
|
|
|
|
# First Answers..
|
|
|
|
for my $answer ( @{ $question->{answers} } ) {
|
|
# Only process the chosen answer..
|
|
my $aId = $answer->{id};
|
|
next if !$validAnswers{$aId};
|
|
|
|
# Answer goto
|
|
if (my $action = $answer->{goto} && $self->processGoto($answer->{goto})) {
|
|
$self->session->log->debug("Branching on Answer goto: $answer->{goto}");
|
|
return $action;
|
|
}
|
|
# Then answer gotoExpression
|
|
if (my $action = $answer->{gotoExpression} && $self->processExpression($answer->{gotoExpression})) {
|
|
$self->session->log->debug("Branching on Answer gotoExpression: $answer->{gotoExpression}");
|
|
return $action;
|
|
}
|
|
# Then answer terminal
|
|
if ($answer->{terminal}) {
|
|
$self->session->log->debug("Answer terminal: $answer->{terminalUrl}");
|
|
return { terminal => $answer->{terminalUrl} };
|
|
}
|
|
}
|
|
|
|
# Then Questions..
|
|
|
|
# Question goto
|
|
if (my $action = $question->{goto} && $self->processGoto($question->{goto})) {
|
|
$self->session->log->debug("Branching on Question goto: $question->{goto}");
|
|
return $action;
|
|
}
|
|
# Then question gotoExpression
|
|
if (my $action = $question->{gotoExpression} && $self->processExpression($question->{gotoExpression})) {
|
|
$self->session->log->debug("Branching on Question gotoExpression: $question->{gotoExpression}");
|
|
return $action;
|
|
}
|
|
# N.B. Questions don't have terminalUrls
|
|
}
|
|
|
|
# Then Sections.. (but if this is the last page of the Section)
|
|
my $newSectionIndex = $self->nextResponseSectionIndex;
|
|
if ($newSectionIndex != $sId) {
|
|
# Section goto
|
|
if (my $action = $section->{goto} && $self->processGoto($section->{goto})) {
|
|
$self->session->log->debug("Branching on Section goto: $section->{goto}");
|
|
return $action;
|
|
}
|
|
# Then section gotoExpression
|
|
if (my $action = $section->{gotoExpression} && $self->processExpression($section->{gotoExpression})) {
|
|
$self->session->log->debug("Branching on Section gotoExpression: $section->{gotoExpression}");
|
|
return $action;
|
|
}
|
|
# Then section terminal
|
|
if ($section->{terminal} && $self->nextResponseSectionIndex != $self->lastResponseSectionIndex) {
|
|
$self->session->log->debug("Section terminal: $section->{terminalUrl}");
|
|
return { terminal => $section->{terminalUrl} };
|
|
}
|
|
}
|
|
|
|
# The above goto and gotoExpression checks will have already called $self->checkForLogicalSection after
|
|
# moving nextResponse, however we need to call it again here for the case where the survey fell
|
|
# through naturally to a logical section
|
|
$self->checkForLogicalSection;
|
|
|
|
$self->session->log->debug("Falling through..");
|
|
return;
|
|
}
|
|
|
|
=head2 checkForLogicalSection
|
|
|
|
Check if the next response section is marked as logical, and if so, immediately processed it.
|
|
Normally, this sub should be called every time lastResponse or nextResponse is modified, so
|
|
that logical sections "automatically" trigger.
|
|
|
|
=cut
|
|
|
|
sub checkForLogicalSection {
|
|
my $self = shift;
|
|
my $section = $self->nextResponseSection();
|
|
if ($section && $section->{logical}) {
|
|
$self->session->log->debug("Processing logical section $section->{variable}");
|
|
$self->recordResponses({});
|
|
}
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 processGoto ( $variable )
|
|
|
|
Looks through all sections and questions for their variable key, in order. If the requested
|
|
$variable matches a variable, then the lastResponse is set so that that section or question
|
|
is the next displayed. If more than one variable name matches, then the first is used.
|
|
|
|
=head3 $variable
|
|
|
|
A variable name to match against all section and question variable names.
|
|
|
|
=cut
|
|
|
|
sub processGoto {
|
|
my $self = shift;
|
|
my $goto = shift;
|
|
|
|
return if !$goto;
|
|
|
|
if ($goto eq 'NEXT_SECTION') {
|
|
$self->session->log->debug("NEXT_SECTION jump target encountered");
|
|
my $lastResponseSectionIndex = $self->lastResponseSectionIndex;
|
|
|
|
# Increment lastRepsonse until nextResponseSectionIndex moves
|
|
while ($self->nextResponseSectionIndex == $lastResponseSectionIndex) {
|
|
$self->lastResponse( $self->lastResponse + 1);
|
|
}
|
|
$self->checkForLogicalSection;
|
|
return 1;
|
|
}
|
|
|
|
if ($goto eq 'END_SURVEY') {
|
|
$self->session->log->debug("END_SURVEY jump target encountered");
|
|
$self->lastResponse( scalar( @{ $self->surveyOrder} ) - 1 );
|
|
$self->checkForLogicalSection;
|
|
return 1;
|
|
}
|
|
|
|
if (defined(my $surveyOrderIndex = $self->surveyOrderIndex($goto))) {
|
|
$self->nextResponse( $surveyOrderIndex );
|
|
$self->checkForLogicalSection;
|
|
return 1;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 processExpression ( $expression )
|
|
|
|
Processes a Survey expression using the Survey Expression Engine.
|
|
|
|
If the expression returns tag data, this data is stored in the response (see L<tags>).
|
|
|
|
If the expression returns a jump target, triggers a call to L<"processGoto">.
|
|
|
|
=head3 $expression
|
|
|
|
The expression. See L<WebGUI::Asset::Wobject::Survey::ExpressionEngine> for more info.
|
|
|
|
=cut
|
|
|
|
sub processExpression {
|
|
my $self = shift;
|
|
my $expression = shift;
|
|
|
|
return if !$expression;
|
|
|
|
# Prepare the ingredients..
|
|
my $values = $self->responseValues( indexBy => 'variable' );
|
|
my $scores = $self->responseScores( indexBy => 'variable' );
|
|
my $tags = $self->tags;
|
|
my %validTargets = map { $_ => 1 } @{$self->survey->getGotoTargets};
|
|
|
|
my $engine = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
|
|
if (my $result = $engine->run($self->session, $expression, { values => $values, scores => $scores, tags => $tags, validTargets => \%validTargets} ) ) {
|
|
# Update tags
|
|
if (my $tags = $result->{tags} ) {
|
|
$self->tags( $tags );
|
|
}
|
|
|
|
if (my $jump = $result->{jump}) {
|
|
$self->session->log->debug("Jumping to [$jump]");
|
|
return $self->processGoto($jump);
|
|
} elsif (exists $result->{exitUrl}) { # may be undefined
|
|
my $exitUrl = $result->{exitUrl};
|
|
$self->session->log->debug("exitUrl triggered [$exitUrl]");
|
|
return { exitUrl => $exitUrl };
|
|
} elsif (my $restart = $result->{restart}) {
|
|
$self->session->log->debug("restart triggered");
|
|
return { restart => $restart };
|
|
} else {
|
|
$self->session->log->debug("No hits, falling through");
|
|
return;
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 recordedResponses
|
|
|
|
Returns an array or response information in this response's survey order.
|
|
|
|
=cut
|
|
|
|
sub recordedResponses{
|
|
my $self = shift;
|
|
my $responses= [
|
|
# {answer info hash}
|
|
];
|
|
# Populate @$responses with the user's data..
|
|
for my $address ( @{ $self->surveyOrder } ) {
|
|
my $question = $self->survey->question( $address );
|
|
my ($sIndex, $qIndex) = (sIndex($address), qIndex($address));
|
|
for my $aIndex (aIndexes($address)) {
|
|
my $question = $self->survey->question([$sIndex,$qIndex]);
|
|
my $answerId = $self->answerId($sIndex, $qIndex, $aIndex);
|
|
if ( defined $self->responses->{$answerId} ) {
|
|
my $answer = $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] );
|
|
push(@$responses, {
|
|
value => $answer->{value} =~ /\w/ ? $answer->{value} : $question->{value},
|
|
recordedAnswer => $answer->{recordedAnswer},
|
|
isCorrect => $answer->{isCorrect},
|
|
answerText => $answer->{text},
|
|
address => [$sIndex,$qIndex,$aIndex],
|
|
questionText => $question->{text},
|
|
questionValue => $question->{value},
|
|
questionType => $question->{questionType}
|
|
}
|
|
);
|
|
}
|
|
}
|
|
}
|
|
return $responses;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 responseValues ( $opts )
|
|
|
|
Returns a lookup table of recorded response values, keyed by either question variable
|
|
or question address. Values come from the L<responses> hash.
|
|
|
|
Accepts the following options:
|
|
|
|
=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 responseValues {
|
|
my $self = shift;
|
|
my %opts = validate(@_, { useText => 0, indexBy => { default => 'variable' } });
|
|
|
|
my %lookup;
|
|
|
|
# Process responses in id order (so that questions with maxAnswers != 1 stringify according
|
|
# to natural ordering of answers (e.g. answer 0, answer 1, etc..
|
|
for my $address (sort keys %{$self->responses}) {
|
|
next if !$address;
|
|
my $response = $self->responses->{$address};
|
|
next if !$response;
|
|
|
|
# Turn responses s-q-a string into an address array
|
|
my @address = split /-/, $address;
|
|
|
|
# Filter out the non-answer entries
|
|
next unless @address == 3;
|
|
|
|
# Grab the corresponding question
|
|
my $question = $self->survey->question([@address]);
|
|
|
|
# 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 ($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};
|
|
|
|
# For verbatim mc answers, combine answer text and recorded value
|
|
if ($answer->{verbatim}) {
|
|
$answerText = "$answerText - \"$response->{verbatim}\"";
|
|
}
|
|
$value = $answerText ? $answerText : $value;
|
|
}
|
|
}
|
|
|
|
# Add identifier => value to our hash
|
|
if (!$question->{maxAnswers} || $question->{maxAnswers} > 1) {
|
|
push @{$lookup{$identifier}}, $value;
|
|
} else {
|
|
$lookup{$identifier} = $value;
|
|
}
|
|
|
|
# For verbatims, also add verbatim value to lookup as identifier_verbatim
|
|
if ($answer->{verbatim}) {
|
|
my $verbatimKey = "${identifier}_verbatim";
|
|
my $verbatimValue = $response->{verbatim};
|
|
if (!$question->{maxAnswers} || $question->{maxAnswers} > 1) {
|
|
push @{$lookup{$verbatimKey}}, $verbatimValue;
|
|
} else {
|
|
$lookup{$verbatimKey} = $verbatimValue;
|
|
}
|
|
}
|
|
}
|
|
return \%lookup;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 responseScores ( $opts )
|
|
|
|
Returns a lookup table of recorded response scores, keyed by either question variable
|
|
or question address. Values 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 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 L<responseValues>
|
|
for my $address (sort keys %$responses) {
|
|
next if !$address;
|
|
my $response = $responses->{$address};
|
|
next if !$response;
|
|
|
|
# Turn responses s-q-a string into an address array
|
|
my @address = split /-/, $address;
|
|
|
|
# Filter out the non-answer entries
|
|
next unless @address == 3;
|
|
|
|
# Grab the corresponding question
|
|
my $question = $self->survey->question([@address]);
|
|
|
|
# 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]);
|
|
|
|
# Use question score if answer score undefined
|
|
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{$identifier} += $score;
|
|
}
|
|
|
|
# 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;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getTemplatedText ($text, $responses)
|
|
|
|
Scans a string of text for instances of "[[var]]". Looks up each match in the given hash reference
|
|
and replaces the string with the associated hash value.
|
|
|
|
This method is used to enable simple templating in Survey Section/Question/Answer text. $responses will
|
|
usually be a hash of all of the users responses so that their previous responses can be displayed in
|
|
the text of later questions.
|
|
|
|
=head3 text
|
|
|
|
A string of text. e.g.
|
|
|
|
Your chose the value [[Q2]] in Question 2
|
|
|
|
=head3 params
|
|
|
|
A hash reference. Each matching key in the string will be replaced with its associated value.
|
|
|
|
=cut
|
|
|
|
sub getTemplatedText {
|
|
my $self = shift;
|
|
my ($text, $params) = validate_pos(@_, { type => SCALAR|UNDEF }, { type => HASHREF });
|
|
$text = q{} if not defined $text;
|
|
|
|
# Turn multi-valued answers into comma-separated text
|
|
for my $value (values %$params) {
|
|
$value = join(',', @$value) if ref $value eq 'ARRAY';
|
|
}
|
|
|
|
# Replace all instances of [[var]] with the value from the $params hash reference
|
|
$text =~ s/\[\[([^\%]*?)\]\]/$params->{$1}/eg;
|
|
|
|
return $text;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 nextQuestions
|
|
|
|
Returns a list (array ref) of the Questions that should be shwon on the next page of the Survey.
|
|
Each Question also contains a list (array ref) of associated Answers.
|
|
|
|
N.B. These are safe copies of the Survey data.
|
|
|
|
The number of questions is determined by the questionsPerPage property of the 'next' section
|
|
in L<"surveyOrder">.
|
|
|
|
Each element of the array ref returned is a question data structure (see
|
|
L<WebGUI::Asset::Wobject::Survey::SurveyJSON>), with some additional fields:
|
|
|
|
=over 4
|
|
|
|
=item sid Section Id field (see L<"sectionId">)
|
|
|
|
=item id Question id (see L<"questionId">.
|
|
|
|
=item answers An array of Answers (see L<WebGUI::Asset::Wobject::Survey::SurveyJSON>), with
|
|
each answer in the array containing an Answer Id (see L<"answerId">)
|
|
|
|
=back
|
|
|
|
Survey, Question and Answer template text is processed here (see L<"getTemplatedText">)
|
|
|
|
=cut
|
|
|
|
sub nextQuestions {
|
|
my $self = shift;
|
|
|
|
# See if we've reached the end of the Survey
|
|
return if $self->surveyEnd;
|
|
|
|
# Get some information about the Section that the next response belongs to..
|
|
my $section = $self->nextResponseSection();
|
|
my $sectionIndex = $self->nextResponseSectionIndex;
|
|
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 $responseValues = $self->responseValues( { useText => 1, indexBy => 'variable' } );
|
|
my $tags = $self->tags;
|
|
|
|
# Merge values and tags hashes for processing [[var]] templated text
|
|
my %templateValues = (%$responseValues, %$tags);
|
|
|
|
# Do text replacement
|
|
$section->{text} = $self->getTemplatedText($section->{text}, \%templateValues);
|
|
|
|
# Collect all the questions to be shown on the next page..
|
|
my @questions;
|
|
QUESTION:
|
|
for my $i (1 .. $questionsPerPage ) {
|
|
my $address = $self->surveyOrder->[ $self->lastResponse + $i ];
|
|
last if(! defined $address);
|
|
my ($sIndex, $qIndex) = (sIndex($address), qIndex($address));
|
|
|
|
# Skip if this is a Section without a Question
|
|
if ( !defined $qIndex ) {
|
|
next;
|
|
}
|
|
|
|
# Stop if we have left the Section
|
|
if ( $sIndex != $sectionIndex ) {
|
|
last;
|
|
}
|
|
|
|
# In rare cases where you change the structure of your survey after
|
|
# someone has already started a response, it's possible for this
|
|
# to be triggered, in which case the easiest course of action is
|
|
# to just skip over the question.
|
|
if (!$self->survey->question( $address )) {
|
|
$self->session->log->debug("Unable to retrieve question for address $sIndex-$qIndex");
|
|
next;
|
|
}
|
|
|
|
# Make a safe copy of the question
|
|
my %questionCopy = %{$self->survey->question( $address )};
|
|
|
|
# Do text replacement
|
|
$questionCopy{text} = $self->getTemplatedText($questionCopy{text}, \%templateValues);
|
|
|
|
# Add any extra fields we want..
|
|
$questionCopy{id} = $self->questionId($sIndex, $qIndex);
|
|
$questionCopy{sid} = $self->sectionId($sIndex);
|
|
|
|
# Rebuild the list of anwers with a safe copy
|
|
delete $questionCopy{answers};
|
|
|
|
if ($questionCopy{questionType} eq 'Tagged') {
|
|
if (!$questionCopy{variable}) {
|
|
$self->session->log->warn("Unable to build Tagged question, question variable must be defined");
|
|
next QUESTION;
|
|
}
|
|
|
|
my $tags = $self->tags;
|
|
my $taggedAnswers = $tags->{"$questionCopy{variable}_TAGGED_ANSWERS"};
|
|
if (!$taggedAnswers || ref $taggedAnswers ne 'ARRAY') {
|
|
$self->session->log->warn("Unable to build Tagged question, $questionCopy{variable}_TAGGED_ANSWERS is invalid");
|
|
next QUESTION;
|
|
}
|
|
|
|
my $aIndex = 0;
|
|
for my $taggedAnswer (@$taggedAnswers) {
|
|
|
|
if (!$taggedAnswer || ref $taggedAnswer ne 'HASH') {
|
|
$self->session->log->warn("Unable to build Tagged question, one or more answers definitions invalid");
|
|
next QUESTION;
|
|
}
|
|
|
|
# Tagged data overrides answer defaults
|
|
my %answerCopy = (%{$self->survey->newAnswer()}, %$taggedAnswer);
|
|
|
|
# Do text replacement
|
|
$answerCopy{text} = $self->getTemplatedText($answerCopy{text}, \%templateValues);
|
|
|
|
# Add any extra fields we want..
|
|
$answerCopy{id} = $self->answerId($sIndex, $qIndex, $aIndex);
|
|
|
|
push @{ $questionCopy{answers} }, \%answerCopy;
|
|
|
|
$aIndex++;
|
|
}
|
|
} else {
|
|
for my $aIndex ( aIndexes($address) ) {
|
|
my %answerCopy
|
|
= %{ $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] )
|
|
|| $self->survey->newAnswer # in case the lookup fails, use a default answer
|
|
};
|
|
|
|
# Do text replacement
|
|
$answerCopy{text} = $self->getTemplatedText($answerCopy{text}, \%templateValues);
|
|
|
|
# Add any extra fields we want..
|
|
$answerCopy{id} = $self->answerId($sIndex, $qIndex, $aIndex);
|
|
|
|
push @{ $questionCopy{answers} }, \%answerCopy;
|
|
}
|
|
}
|
|
|
|
push @questions, \%questionCopy;
|
|
}
|
|
return @questions;
|
|
}
|
|
|
|
=head2 sectionId
|
|
|
|
Convenience method to construct a Section Id from the given Section index.
|
|
|
|
A Section Id is identical to a Section index. This method is only present for consistency with questionId and answerId.
|
|
|
|
=cut
|
|
|
|
sub sectionId {
|
|
my $self = shift;
|
|
my $sIndex = shift;
|
|
|
|
return if !defined $sIndex;
|
|
|
|
return $sIndex;
|
|
}
|
|
|
|
=head2 questionId
|
|
|
|
Convenience method to construct a Question Id from the given Section index and Question index.
|
|
|
|
The id is constructed by hyphenating the Section index and Question index.
|
|
|
|
=cut
|
|
|
|
sub questionId {
|
|
my $self = shift;
|
|
my ($sIndex, $qIndex) = @_;
|
|
|
|
return if !defined $sIndex || !defined $qIndex;
|
|
|
|
return "$sIndex-$qIndex";
|
|
}
|
|
|
|
=head2 answerId
|
|
|
|
Convenience method to construct an Answer Id from the given Section index, Question index and Answer index.
|
|
|
|
The id is constructed by hyphenating all three indices.
|
|
|
|
=cut
|
|
|
|
sub answerId {
|
|
my $self = shift;
|
|
my ($sIndex, $qIndex, $aIndex) = @_;
|
|
|
|
return if !defined $sIndex || !defined $qIndex || !defined $aIndex;
|
|
|
|
return "$sIndex-$qIndex-$aIndex";
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 surveyEnd
|
|
|
|
Returns true if the current index stored in lastResponse is greater than or
|
|
equal to the number of sections in the survey order.
|
|
|
|
=cut
|
|
|
|
sub surveyEnd {
|
|
my $self = shift;
|
|
|
|
return 1 if ( $self->lastResponse >= $#{ $self->surveyOrder } );
|
|
return 0;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 sIndex ($address)
|
|
|
|
Convenience sub to extract the section index from an address in the L<"surveyOrder"> array.
|
|
This method exists purely to improve code readability.
|
|
This method is identical to L<WebGUI::Asset::Wobject::Survey::SurveyJSON/sIndex>.
|
|
|
|
=cut
|
|
|
|
sub sIndex { $_[0][0] }
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 qIndex ($address)
|
|
|
|
Convenience sub to extract the question index from an address in the L<"surveyOrder"> array.
|
|
This method exists purely to improve code readability.
|
|
This method is identical to L<WebGUI::Asset::Wobject::Survey::SurveyJSON/qIndex>.
|
|
|
|
=cut
|
|
|
|
sub qIndex { $_[0][1] }
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 aIndexes ($address)
|
|
|
|
Convenience sub to extract the array of answer indices from an address in the L<"surveyOrder"> array.
|
|
This method exists purely to improve code readability.
|
|
Unlike sIndex and qIndex, this method is different to L<WebGUI::Asset::Wobject::Survey::SurveyJSON/aIndex>.
|
|
This is because the third element of the L<"surveyOrder"> address array ref in is an array of answer indices.
|
|
|
|
=cut
|
|
|
|
sub aIndexes {
|
|
my $address = shift;
|
|
|
|
if (my $indexes = $address->[2]) {
|
|
return @{ $indexes };
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 showSummary ( [$sectionAddresses] )
|
|
|
|
showSummary returns the current responses summary for the entire response, if
|
|
no address is passed in, or just the sections addressed by $sectionAddresses.
|
|
|
|
For each section, the total correct, wrong, time taken, and points are returned. And each
|
|
question is listed with the text, given score, user response, and if it was correct.
|
|
This list is meant for a template and only what is needed should be shown.
|
|
|
|
A summary of the entire suvey,
|
|
|
|
=cut
|
|
|
|
sub showSummary{
|
|
my $self = shift;
|
|
my $sectionAddies = shift;#array of section addresses
|
|
|
|
my $all = 0;
|
|
$all = 1 if(! $sectionAddies);
|
|
|
|
my ($summaries);
|
|
|
|
my $responses = $self->recordedResponses();
|
|
my %goodSection;
|
|
map{$goodSection{$_} = 1} @$sectionAddies;
|
|
|
|
return if(! $responses);
|
|
|
|
my ($sectionIndex, $responseIndex) = (-1, 1);
|
|
my ($currentSection,$currentQuestion) = (-1,-1);
|
|
($summaries->{totalCorrect},$summaries->{totalIncorrect}) = (0,0);
|
|
|
|
for my $response (@$responses){
|
|
if(! $all and ! $goodSection{$response->{address}->[0]}){next;}
|
|
if($response->{isCorrect}){
|
|
$summaries->{totalCorrect}++;
|
|
}else{
|
|
$summaries->{totalIncorrect}++;
|
|
}
|
|
$summaries->{totalAnswers}++;
|
|
if($currentSection != $response->{address}->[0]){
|
|
$summaries->{totalSections}++;
|
|
$sectionIndex++;
|
|
$responseIndex = -1;
|
|
$currentSection = $response->{address}->[0];
|
|
}
|
|
if($currentQuestion != $response->{address}->[1]){
|
|
$summaries->{totalQuestions}++;
|
|
}
|
|
_loadSectionIntoSummary(\%{$summaries->{sections}->[$sectionIndex]}, $response);
|
|
$responseIndex++;
|
|
_loadResponseIntoSummary(\%{$summaries->{sections}->[$sectionIndex]->{responses}->[$responseIndex]},
|
|
$response,
|
|
$self->survey->{multipleChoiceTypes});
|
|
}
|
|
return $summaries;
|
|
}
|
|
sub _loadResponseIntoSummary{
|
|
my $node = shift;
|
|
my $response = shift;
|
|
my $types = shift;
|
|
|
|
$node->{"Question ID"} = $response->{address}->[1] + 1;
|
|
$node->{"Question Text"} = $response->{questionText};
|
|
$node->{"Answer ID"} = $response->{address}->[2] + 1;
|
|
if($response->{isCorrect}){
|
|
$node->{Correct} = "Y";
|
|
$node->{Score} = $response->{value};
|
|
}else{
|
|
$node->{Correct} = "N";
|
|
$node->{Score} = 0;
|
|
}
|
|
$node->{"Answer Text"} = $response->{answerText};
|
|
|
|
#test if it is a multiple choide type
|
|
if($types->{$response->{questionType}}){
|
|
$node->{Value} = $response->{value};
|
|
}else{
|
|
$node->{Value} = $response->{recordedValue};
|
|
}
|
|
}
|
|
sub _loadSectionIntoSummary{
|
|
my $node = shift;
|
|
my $response = shift;
|
|
$node->{id} = $response->{address}->[0] + 1;
|
|
$node->{inCorrect} = 0 if(!defined $node->{inCorrect});
|
|
$node->{score} = 0 if(!defined $node->{score});
|
|
$node->{correct} = 0 if(!defined $node->{correct});
|
|
$node->{total} = 0 if(!defined $node->{total});
|
|
$node->{total}++;
|
|
if($response->{isCorrect} == 1){
|
|
$node->{score} += $response->{value};
|
|
$node->{correct}++;
|
|
}else{
|
|
$node->{inCorrect}++;
|
|
}
|
|
|
|
}
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 responseReport
|
|
|
|
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>.
|
|
|
|
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
|
|
|
|
sub responseReport {
|
|
my $self = shift;
|
|
|
|
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 );
|
|
|
|
# Skip if this is a Section without a Question
|
|
next unless defined $qIndex;
|
|
|
|
# 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 ] );
|
|
|
|
# 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 => \@answer_responses
|
|
};
|
|
}
|
|
return \@report;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 response
|
|
|
|
Accessor for the Perl hash containing Response data
|
|
|
|
=cut
|
|
|
|
sub response {
|
|
my $self = shift;
|
|
return $self->{_response};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 responses
|
|
|
|
Mutator. Note, this is an unsafe reference.
|
|
|
|
This data structure stores a snapshot of all question responses. Both question data and answer data
|
|
is stored in this hash reference.
|
|
|
|
Questions keys are constructed by hypenating the relevant L<"sIndex"> and L<"qIndex">.
|
|
Answer keys are constructed by hypenating the relevant L<"sIndex">, L<"qIndex"> and L<aIndex|"aIndexes">.
|
|
|
|
{
|
|
# Question entries only contain a comment field, e.g.
|
|
'0-0' => {
|
|
comment => "question comment",
|
|
},
|
|
# ...
|
|
# Answers entries contain: value (the recorded value), time and verbatim field.
|
|
'0-0-0' => {
|
|
value => "recorded answer value",
|
|
time => time(),
|
|
verbatim => "answer verbatim",
|
|
},
|
|
# ...
|
|
}
|
|
|
|
=cut
|
|
|
|
sub responses {
|
|
my $self = shift;
|
|
my $responses = shift;
|
|
if ( defined $responses ) {
|
|
$self->response->{responses} = $responses;
|
|
}
|
|
return $self->response->{responses};
|
|
}
|
|
|
|
=head2 pop
|
|
|
|
=cut
|
|
|
|
sub pop {
|
|
my $self = shift;
|
|
my %responses = %{ $self->responses };
|
|
|
|
# Iterate over responses first time to determine time of most recent response(s)
|
|
my $lastResponseTime;
|
|
for my $r ( values %responses ) {
|
|
if ( $r->{time} ) {
|
|
$lastResponseTime
|
|
= !$lastResponseTime || $r->{time} > $lastResponseTime
|
|
? $r->{time}
|
|
: $lastResponseTime
|
|
;
|
|
}
|
|
}
|
|
|
|
return unless $lastResponseTime;
|
|
|
|
my $popped;
|
|
my $poppedQuestions;
|
|
# Iterate again, removing most recent responses
|
|
while (my ($address, $r) = each %responses ) {
|
|
if ( $r->{time} == $lastResponseTime) {
|
|
$popped->{$address} = $r;
|
|
delete $self->responses->{$address};
|
|
|
|
# Remove associated question/comment entry
|
|
my ($sIndex, $qIndex, $aIndex) = split /-/, $address;
|
|
my $qAddress = "$sIndex-$qIndex";
|
|
$popped->{$qAddress} = $responses{$qAddress};
|
|
delete $self->responses->{$qAddress};
|
|
|
|
# while we're here, build lookup table of popped question ids
|
|
$poppedQuestions->{$qAddress} = 1;
|
|
}
|
|
}
|
|
|
|
# Now, nextResponse should be set to index of the first popped question we can find in surveyOrder
|
|
my $nextResponse = 0;
|
|
for my $address (@{ $self->surveyOrder }) {
|
|
my $questionId = "$address->[0]-$address->[1]";
|
|
if ($poppedQuestions->{$questionId} ) {
|
|
$self->session->log->debug("setting nextResponse to $nextResponse");
|
|
$self->nextResponse($nextResponse);
|
|
last;
|
|
}
|
|
$nextResponse++;
|
|
}
|
|
|
|
return $popped;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 survey
|
|
|
|
Returns a referece to the SurveyJSON object that this object was created with.
|
|
|
|
Note, this is an unsafe reference.
|
|
|
|
=cut
|
|
|
|
sub survey {
|
|
my $self = shift;
|
|
return $self->{_survey};
|
|
}
|
|
|
|
1;
|