Implemented Survey branching expressions (#9233). Woot!
This commit is contained in:
Patrick Donelan
parent
ad0f3b388d
commit
fc3851705a
6 changed files with 268 additions and 5 deletions
|
|
@ -458,9 +458,7 @@ sub www_loadSurvey {
|
|||
}
|
||||
|
||||
# Generate the list of valid goto targets
|
||||
my @section_vars = map {$_->{variable}} @{$self->survey->sections};
|
||||
my @question_vars = map {$_->{variable}} @{$self->survey->questions};
|
||||
my @gotoTargets = grep {$_ ne ''} (@section_vars, @question_vars);
|
||||
my @gotoTargets = $self->survey->getGotoTargets;
|
||||
|
||||
my %buttons;
|
||||
$buttons{question} = $$address[0];
|
||||
|
|
|
|||
|
|
@ -400,6 +400,7 @@ sub recordResponses {
|
|||
my $terminal = 0;
|
||||
my $terminalUrl;
|
||||
my $goto;
|
||||
my $gotoExpression;
|
||||
|
||||
my $section = $self->nextSection();#which gets the current section for the just submitted questions. IE, current response pointer has not moved forward for these questions
|
||||
|
||||
|
|
@ -444,6 +445,9 @@ sub recordResponses {
|
|||
elsif ( $answer->{goto} =~ /\w/ ) {
|
||||
$goto = $answer->{goto};
|
||||
}
|
||||
elsif ( $answer->{gotoExpression} =~ /\w/ ) {
|
||||
$gotoExpression = $answer->{gotoExpression};
|
||||
}
|
||||
} ## end if ( defined( $responses...
|
||||
} ## end for my $answer ( @{ $question...
|
||||
$qAnswered = 0 if ( !$aAnswered and $question->{required} );
|
||||
|
|
@ -456,6 +460,7 @@ sub recordResponses {
|
|||
if ($qAnswered) {
|
||||
$self->lastResponse( $self->lastResponse + @$questions );
|
||||
$self->goto($goto) if ( defined $goto );
|
||||
$self->gotoExpression($gotoExpression) if ( defined $gotoExpression );
|
||||
}
|
||||
else {
|
||||
$terminal = 0;
|
||||
|
|
@ -501,6 +506,164 @@ sub goto {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 gotoExpression ( $gotoExpression )
|
||||
|
||||
=head3 $gotoExpression
|
||||
|
||||
The gotoExpression (one expression per line)
|
||||
|
||||
=head3 Explanation
|
||||
|
||||
A gotoExpression is a list of expressions (one per line) of the form:
|
||||
target: expression
|
||||
target: expression
|
||||
|
||||
This subroutine iterates through the list, processing each line and, all things being
|
||||
well, evaluates the expression. The first expression to evaluate to true triggers a
|
||||
call to goto($target).
|
||||
|
||||
The expression is a simple subset of the formula language used in spreadsheet programs such as Excel, OpenOffice, Google Docs etc..
|
||||
|
||||
Here is an example using section variables S1 and S2 as jump targets and question variables Q1-3 in the expression.
|
||||
It jumps to S1 if the user's answer to Q1 has a value of 3, jumps to S2 if Q2 + Q3 < 10, and otherwise doesn't branch at all (the default).
|
||||
S1: Q1 = 3
|
||||
S2: Q2 + Q3 < 10
|
||||
|
||||
=head3 Arguments are evaluated as follows:
|
||||
|
||||
Numeric arguments evaluate as numbers
|
||||
* No support for strings (and hence no string matching)
|
||||
* Question variable names (e.g. Q1) evaluate to the numeric value associated with user's answer to that question, or undefined if the user has not answered that question
|
||||
|
||||
Binary comparisons operators: = != < <= >= >
|
||||
* return boolean values based on perl's equivalent numeric comparison operators
|
||||
|
||||
Simple math operators: + - * /
|
||||
* return numeric values
|
||||
|
||||
Later we may add Boolean operators: AND( x; y; z; ... ), OR( x; y; z; ... ), NOT( x )
|
||||
* args separated by semicolons (presumably because spreadsheet formulas use commas to indicate cell ranges)
|
||||
|
||||
Later still you may be able to say AVG(section1) or SUM(section3) and have those functions automatically compute their result over the set of all questions in the given section.
|
||||
But for now those things can be done manually using the limited subset defined.
|
||||
|
||||
=cut
|
||||
|
||||
sub gotoExpression {
|
||||
my $self = shift;
|
||||
my $expression = shift;
|
||||
|
||||
my %responses = (
|
||||
# questionName => response answer value
|
||||
);
|
||||
|
||||
# Populate %responses with the user's data..
|
||||
foreach my $q (@{ $self->returnResponseForReporting() }) {
|
||||
if ($q->{questionName} =~ /\w/) {
|
||||
my $value = $q->{answers}[0]{value};
|
||||
$responses{$q->{questionName}} = $value if defined $value;
|
||||
}
|
||||
}
|
||||
|
||||
# Process gotoExpressions one after the other (first one that's true wins)
|
||||
foreach my $line (split '\n', $expression) {
|
||||
my $processed = $self->processGotoExpression($line, \%responses);
|
||||
|
||||
next unless $processed;
|
||||
|
||||
# (ab)use perl's eval to evaluate the processed expression
|
||||
my $result = eval "$processed->{expression}";
|
||||
$self->warn($@) if $@;
|
||||
|
||||
if ($result) {
|
||||
$self->debug("Truthy, goto [$processed->{target}]");
|
||||
$self->goto($processed->{target});
|
||||
return $processed;
|
||||
} else {
|
||||
$self->debug("Falsy, not branching");
|
||||
next;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
=head2 processGotoExpression ( $expression, $responses)
|
||||
|
||||
Parses a single gotoExpression. Returns undef if processing fails, or the following hashref
|
||||
if things work out well:
|
||||
{ target => $target, expression => $expression }
|
||||
|
||||
=head3 $expression
|
||||
|
||||
The expression to process
|
||||
|
||||
=head3 $responses
|
||||
|
||||
Hashref that maps questionNames to response values
|
||||
|
||||
=head3 Explanation:
|
||||
|
||||
Uses the following simple strategy:
|
||||
|
||||
First, parse the expression as:
|
||||
target: expression
|
||||
|
||||
Replace each questionName with its response value (from the $responses hashref)
|
||||
|
||||
Massage the expression into valid perl
|
||||
|
||||
Check that only valid tokens remain. This last step ensures that any invalid questionNames in
|
||||
the expression generate an error because our list of valid tokens doesn't include a-z
|
||||
|
||||
=cut
|
||||
|
||||
sub processGotoExpression {
|
||||
my $self = shift;
|
||||
my $expression = shift;
|
||||
my $responses = shift;
|
||||
|
||||
$self->debug("Processing gotoExpression: $expression");
|
||||
|
||||
# Valid gotoExpression tokens are..
|
||||
my $tokens = qr{\s|[-0-9=!<>+*/.()]};
|
||||
|
||||
my ( $target, $rest ) = $expression =~ /\s* ([^:]+?) \s* : \s* (.*)/x;
|
||||
|
||||
$self->debug("Parsed as Target: [$target], Expression: [$rest]");
|
||||
|
||||
if ( !defined $target ) {
|
||||
$self->warn('Target undefined');
|
||||
return;
|
||||
}
|
||||
|
||||
if ( !defined $rest || $rest eq '' ) {
|
||||
$self->warn('Expression undefined');
|
||||
return;
|
||||
}
|
||||
|
||||
# Replace each questionName with its response value
|
||||
while ( my ( $questionName, $response ) = each %$responses ) {
|
||||
$rest =~ s/$questionName/$response/g;
|
||||
}
|
||||
|
||||
# convert '=' to '==' but don't touch '!=', '<=' or '>='
|
||||
$rest =~ s/(?<![!<>])=(?!=)/==/g;
|
||||
|
||||
if ( $rest !~ /^$tokens+$/ ) {
|
||||
$self->warn("Contains invalid tokens: $rest");
|
||||
return;
|
||||
}
|
||||
|
||||
$self->debug("Processed as: $rest");
|
||||
|
||||
return {
|
||||
target => $target,
|
||||
expression => $rest,
|
||||
};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getPreviousAnswer
|
||||
|
||||
=cut
|
||||
|
|
@ -691,9 +854,23 @@ Logs an error to the webgui log file, using the session logger.
|
|||
=cut
|
||||
|
||||
sub log {
|
||||
my ( $self, $message ) = @_;
|
||||
my ( $self, $message) = @_;
|
||||
if ( defined $self->{log} ) {
|
||||
$self->{log}->error($message);
|
||||
}
|
||||
}
|
||||
|
||||
sub debug {
|
||||
my ( $self, $message) = @_;
|
||||
if ( defined $self->{log} ) {
|
||||
$self->{log}->debug($message);
|
||||
}
|
||||
}
|
||||
|
||||
sub warn {
|
||||
my ( $self, $message) = @_;
|
||||
if ( defined $self->{log} ) {
|
||||
$self->{log}->warn($message);
|
||||
}
|
||||
}
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -318,6 +318,14 @@ sub getSectionEditVars {
|
|||
return \%var;
|
||||
} ## end sub getSectionEditVars
|
||||
|
||||
sub getGotoTargets {
|
||||
my $self = shift;
|
||||
|
||||
my @section_vars = map {$_->{variable}} @{$self->sections};
|
||||
my @question_vars = map {$_->{variable}} @{$self->questions};
|
||||
return grep {$_ ne ''} (@section_vars, @question_vars);
|
||||
}
|
||||
|
||||
=head2 getQuestionEditVars ( $address )
|
||||
|
||||
Get a safe copy of the variables for this question, to use for editing purposes. Adds
|
||||
|
|
@ -707,6 +715,7 @@ sub newAnswer {
|
|||
textCols => 10,
|
||||
textRows => 5,
|
||||
goto => '',
|
||||
gotoExpression => '',
|
||||
recordedAnswer => '',
|
||||
isCorrect => 1,
|
||||
min => 1,
|
||||
|
|
|
|||
|
|
@ -195,6 +195,10 @@ our $I18N = {
|
|||
message => q|Jump to:|,
|
||||
lastUpdated => 1224686319
|
||||
},
|
||||
'jump expression' => {
|
||||
message => q|Jump expression:|,
|
||||
lastUpdated => 1229318805
|
||||
},
|
||||
'text answer' => {
|
||||
message => q|Text answer|,
|
||||
lastUpdated => 1224686319
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 52;
|
||||
my $tests = 77;
|
||||
plan tests => $tests + 1;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -319,6 +319,80 @@ is($rJSON->lastResponse(), 0, 'goto: works on existing question');
|
|||
$rJSON->goto('goto 3-0');
|
||||
is($rJSON->lastResponse(), 5, 'goto: finds first if there are duplicates');
|
||||
|
||||
####################################################
|
||||
#
|
||||
# processGotoExpression
|
||||
#
|
||||
####################################################
|
||||
is($rJSON->processGotoExpression(),
|
||||
undef, 'processGotoExpression undef with empty arguments');
|
||||
is($rJSON->processGotoExpression('blah-dee-blah-blah'),
|
||||
undef, '.. and undef with duff expression');
|
||||
is($rJSON->processGotoExpression(':'),
|
||||
undef, '.. and undef with missing target');
|
||||
is($rJSON->processGotoExpression('t1:'),
|
||||
undef, '.. and undef with missing expression');
|
||||
cmp_deeply($rJSON->processGotoExpression('t1: 1'),
|
||||
{ target => 't1', expression => '1'}, 'works for simple numeric expression');
|
||||
cmp_deeply($rJSON->processGotoExpression('t1: 1 - 23 + 456 * (78 / 9.0)'),
|
||||
{ target => 't1', expression => '1 - 23 + 456 * (78 / 9.0)'}, 'works for expression using all algebraic tokens');
|
||||
is($rJSON->processGotoExpression('t1: 1 + &'), undef, '.. but disallows expression containing non-whitelisted token');
|
||||
cmp_deeply($rJSON->processGotoExpression('t1: 1 = 3'),
|
||||
{ target => 't1', expression => '1 == 3'}, 'converts single = to ==');
|
||||
cmp_deeply($rJSON->processGotoExpression('t1: 1 != 3 <= 4 >= 5'),
|
||||
{ target => 't1', expression => '1 != 3 <= 4 >= 5'}, q{..but doesn't mess with other ops containing =});
|
||||
cmp_deeply($rJSON->processGotoExpression('t1: q1 + q2 * q3 - 4', { q1 => 11, q2 => 22, q3 => 33}),
|
||||
{ target => 't1', expression => '11 + 22 * 33 - 4'}, 'substitues q for value');
|
||||
cmp_deeply($rJSON->processGotoExpression('t1: a silly var name * 10 + another var name', { 'a silly var name' => 345, 'another var name' => 456}),
|
||||
{ target => 't1', expression => '345 * 10 + 456'}, '..it even works for vars with spaces in their names');
|
||||
is($rJSON->processGotoExpression('t1: qX + 3', { q1 => '7'}),
|
||||
undef, q{..but doesn't like invalid var names});
|
||||
|
||||
####################################################
|
||||
#
|
||||
# gotoExpression
|
||||
#
|
||||
####################################################
|
||||
|
||||
$rJSON->survey->section([0])->{variable} = 's0';
|
||||
$rJSON->survey->section([2])->{variable} = 's2';
|
||||
$rJSON->survey->question([1,0])->{variable} = 's1q0';
|
||||
$rJSON->survey->answer([1,0,0])->{value} = 3;
|
||||
|
||||
$rJSON->lastResponse(2);
|
||||
$rJSON->recordResponses($session, {
|
||||
'1-0comment' => 'Section 1, question 0 comment',
|
||||
'1-0-0' => 'First answer',
|
||||
'1-0-0comment' => 'Section 1, question 0, answer 0 comment',
|
||||
});
|
||||
is($rJSON->gotoExpression('blah-dee-blah-blah'), undef, 'invalid gotoExpression is false');
|
||||
ok($rJSON->gotoExpression('s0: s1q0 = 3'), '3 == 3 is true');
|
||||
ok(!$rJSON->gotoExpression('s0: s1q0 = 4'), '3 == 4 is false');
|
||||
ok($rJSON->gotoExpression('s0: s1q0 != 2'), '3 != 2 is true');
|
||||
ok(!$rJSON->gotoExpression('s0: s1q0 != 3'), '3 != 3 is false');
|
||||
ok($rJSON->gotoExpression('s0: s1q0 > 2'), '3 > 2 is true');
|
||||
ok($rJSON->gotoExpression('s0: s1q0 < 4'), '3 < 2 is true');
|
||||
ok(!$rJSON->gotoExpression('s0: s1q0 >= 4'), '3 >= 4 is false');
|
||||
ok(!$rJSON->gotoExpression('s0: s1q0 <= 2'), '3 >= 4 is false');
|
||||
|
||||
cmp_deeply($rJSON->gotoExpression(<<"END_EXPRESSION"), {target => 's2', expression => '3 == 3'}, 'first true expression wins');
|
||||
s0: s1q0 <= 2
|
||||
s2: s1q0 = 3
|
||||
END_EXPRESSION
|
||||
|
||||
ok(!$rJSON->gotoExpression(<<"END_EXPRESSION"), 'but multiple false expressions still false');
|
||||
s0: s1q0 <= 2
|
||||
s2: s1q0 = 345
|
||||
END_EXPRESSION
|
||||
|
||||
$rJSON->gotoExpression('s0: s1q0 = 3');
|
||||
is($rJSON->lastResponse(), -1, '.. lastResponse changed to -1 due to goto(s0)');
|
||||
$rJSON->gotoExpression('s2: s1q0 = 3');
|
||||
is($rJSON->lastResponse(), 4, '.. lastResponse changed to 4 due to goto(s2)');
|
||||
|
||||
$rJSON->{responses} = {};
|
||||
$rJSON->questionsAnswered(-1 * $rJSON->questionsAnswered);
|
||||
|
||||
####################################################
|
||||
#
|
||||
# recordResponses
|
||||
|
|
|
|||
|
|
@ -2118,6 +2118,7 @@ sub getBareSkeletons {
|
|||
textCols => 10,
|
||||
textRows => 5,
|
||||
goto => '',
|
||||
gotoExpression => '',
|
||||
recordedAnswer => '',
|
||||
isCorrect => 1,
|
||||
min => 1,
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue