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

Survey tweaks

Browse source 
Added Survey 'Tagged' question type, which builds its answers dynamically from tagged data
Made Survey test suite more forgiving about JSON parsing
This commit is contained in:
Patrick Donelan 2009-05-19 02:45:45 +00:00
parent a9638ae691
commit 59329e9718
4 changed files with 198 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1085,6 +1085,7 @@ sub nextQuestions {
# Collect all the questions to be shown on the next page.. # Collect all the questions to be shown on the next page..
my @questions; my @questions;
QUESTION:
for my $i (1 .. $questionsPerPage ) { for my $i (1 .. $questionsPerPage ) {
my $address = $self->surveyOrder->[ $self->lastResponse + $i ]; my $address = $self->surveyOrder->[ $self->lastResponse + $i ];
last if(! defined $address); last if(! defined $address);
@ -1112,17 +1113,55 @@ sub nextQuestions {
# Rebuild the list of anwers with a safe copy # Rebuild the list of anwers with a safe copy
delete $questionCopy{answers}; delete $questionCopy{answers};
for my $aIndex ( aIndexes($address) ) {
my %answerCopy = %{ $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] ) }; 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);
# Do text replacement # Add any extra fields we want..
$answerCopy{text} = $self->getTemplatedText($answerCopy{text}, \%templateValues); $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 ] ) };
# Add any extra fields we want.. # Do text replacement
$answerCopy{id} = $self->answerId($sIndex, $qIndex, $aIndex); $answerCopy{text} = $self->getTemplatedText($answerCopy{text}, \%templateValues);
push @{ $questionCopy{answers} }, \%answerCopy; # Add any extra fields we want..
$answerCopy{id} = $self->answerId($sIndex, $qIndex, $aIndex);
push @{ $questionCopy{answers} }, \%answerCopy;
}
} }
push @questions, \%questionCopy; push @questions, \%questionCopy;
} }
return @questions; return @questions;

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

@ -128,6 +128,9 @@ sub loadTypes {
if(! defined $self->{multipleChoiceTypes}){ if(! defined $self->{multipleChoiceTypes}){
my $refs = $self->session->db->buildArrayRefOfHashRefs("SELECT questionType, answers FROM Survey_questionTypes"); my $refs = $self->session->db->buildArrayRefOfHashRefs("SELECT questionType, answers FROM Survey_questionTypes");
map($self->{multipleChoiceTypes}->{$_->{questionType}} = $_->{answers} ? from_json($_->{answers}) : {}, @$refs); map($self->{multipleChoiceTypes}->{$_->{questionType}} = $_->{answers} ? from_json($_->{answers}) : {}, @$refs);
# Also add 'Tagged' question type to multipleChoiceTypes hash, since it is treated like the other mc types
$self->{multipleChoiceTypes}->{Tagged} = {};
} }
} }
@ -1014,7 +1017,10 @@ sub updateQuestionAnswers {
push @{ $question->{answers} }, $self->newAnswer(); push @{ $question->{answers} }, $self->newAnswer();
$address_copy[2] = 0; $address_copy[2] = 0;
$self->update( \@address_copy, { 'text', 'Email:' } ); $self->update( \@address_copy, { 'text', 'Email:' } );
} }
elsif ( $type eq 'Tagged' ) {
# Tagged question should have no answers created for it
}
elsif ( my $answerBundle = $self->getMultiChoiceBundle($type) ) { elsif ( my $answerBundle = $self->getMultiChoiceBundle($type) ) {
# We found a known multi-choice bundle. # We found a known multi-choice bundle.
# Add the bundle of multi-choice answers # Add the bundle of multi-choice answers
@ -1254,7 +1260,7 @@ sub validateSurvey{
if(my $error = $self->validateGotoExpression($question,$goodTargets)){ if(my $error = $self->validateGotoExpression($question,$goodTargets)){
push @messages,"Section $sNum Question $qNum has invalid Jump Expression: \"$question->{gotoExpression}\". Error: $error"; push @messages,"Section $sNum Question $qNum has invalid Jump Expression: \"$question->{gotoExpression}\". Error: $error";
} }
if($#{$question->{answers}} < 0){ if($#{$question->{answers}} < 0 && $question->{questionType} ne 'Tagged'){
push @messages,"Section $sNum Question $qNum does not have any answers."; push @messages,"Section $sNum Question $qNum does not have any answers.";
} }
if(! $question->{text} =~ /\w/){ if(! $question->{text} =~ /\w/){

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

@ -4,7 +4,7 @@ use strict;
use base qw/WebGUI::Crud/; use base qw/WebGUI::Crud/;
use WebGUI::International; use WebGUI::International;
use Test::Deep::NoTest; use Test::Deep::NoTest;
use JSON; use JSON::PP;
use Params::Validate qw(:all); use Params::Validate qw(:all);
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } ); Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
@ -81,9 +81,13 @@ sub crud_definition {
syntax => 'js', syntax => 'js',
defaultValue => <<END_SPEC, defaultValue => <<END_SPEC,
[ [
{ {
test: {}, "name": "My Test",
"test": {
"variable1": "yes",
"next": "section2",
}, },
},
] ]
END_SPEC END_SPEC
}; };
@ -107,13 +111,15 @@ sub run {
my $spec = $self->get('test') my $spec = $self->get('test')
or return { tap => "Bail Out! Test spec undefined" }; or return { tap => "Bail Out! Test spec undefined" };
# Use JSON::PP rather than JSON::XS so that we can use things like allow_barekey
my $json = JSON::PP->new->relaxed->allow_barekey->allow_singlequote;
eval { eval {
$spec = from_json($spec, { relaxed => 1 } ); $spec = $json->decode($spec); # N.B. This will change to from_json when JSON upgraded to >=2.14
}; };
if ($@) { if ($@) {
my $error = $@; my $error = $@;
$error =~ s/(.*?) at .*/$1/s; # don't reveal too much # $error =~ s/(.*?) at .*/$1/s; # don't reveal too much
return { tap => "Bail Out! Invalid test spec: $error" }; return { tap => "Bail Out! Invalid test spec: $error" };
} }
@ -180,7 +186,7 @@ sub run {
} ); } );
} }
else { else {
push @tap, "Bail Out!"; push @tap, "Bail Out! Invalid test definition";
} }
} }
@ -231,26 +237,57 @@ sub _test {
my $testCount = ++${$opts{testCount_ref}}; my $testCount = ++${$opts{testCount_ref}};
# ..and the test-specific arguments # ..and the test-specific arguments
my ($next, $tagged, $score, $setup ) = @{$args}{qw(next tagged score setup)}; my ($next, $tagged, $score, $page, $setup ) = @{$args}{qw(next tagged score page setup)};
delete $args->{next}; delete $args->{next};
delete $args->{tagged}; delete $args->{tagged};
delete $args->{score}; delete $args->{score};
delete $args->{page};
delete $args->{setup}; delete $args->{setup};
# n.b. everything left in %args assumed to be variable => answer_spec # n.b. everything left in %args assumed to be variable => answer_spec
my $fakeTestCount = 0; if (!$next && !$tagged && !$score && !$page && !$setup && scalar(%$args) == 0 ) {
if ($setup) { return fail($testCount, "Nothing to do");
}
if ($page) {
# Recursively call ourselves (ignoring the returned TAP), so that rJSON gets # Recursively call ourselves (ignoring the returned TAP), so that rJSON gets
# updated with responses, simulating the setup spec happening in the past # updated with responses, simulating the page spec happening in the past
my $fakeTestCount = 0;
$self->_test( { $self->_test( {
responseJSON => $rJSON, responseJSON => $rJSON,
surveyOrder => $surveyOrder, surveyOrder => $surveyOrder,
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName, surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
testCount_ref => \$fakeTestCount, testCount_ref => \$fakeTestCount,
args => $setup, args => $page,
} ); } );
} }
# Setup any fake data the user wants prior to the test
if ($setup && ref $setup eq 'HASH') {
my %existingTags = %{$rJSON->tags};
# Process tags
# N.B. Make sure we add to existing tags instead of overwriting
if (ref $setup->{tag} eq 'HASH') {
# already a hash, so store it right away
$rJSON->tags( {%existingTags, %{$setup->{tag}} });
} elsif (ref $setup->{tag} eq 'ARRAY') {
# turn array into hash before storing it
my $tags;
for my $tag (@{$setup->{tag}}) {
if (ref $tag eq 'HASH') {
# Individual item is a single key/value hash
my ($key, $value) = %$tag;
$tags->{$key} = $value;
} else {
# Individual item is a string, default to boolean truth flag
$tags->{$tag} = 1; # default to 1
}
}
$rJSON->tags( {%existingTags, %$tags });
}
}
# Record responses # Record responses
my $responses = {}; my $responses = {};
my $lowestIndex; my $lowestIndex;
@ -300,15 +337,18 @@ sub _test {
} }
} }
$rJSON->nextResponse($lowestIndex); my ($pageSection, $pageQuestion);
if (defined $lowestIndex) {
$rJSON->nextResponse($lowestIndex);
$pageSection = $rJSON->survey->section($surveyOrder->[$lowestIndex]);
$pageQuestion = $rJSON->survey->question($surveyOrder->[$lowestIndex]);
}
my $pageSection = $rJSON->survey->section($surveyOrder->[$lowestIndex]);
my $pageQuestion = $rJSON->survey->question($surveyOrder->[$lowestIndex]);
if (!$name) { if (!$name) {
$name = "Checking "; $name = "Checking ";
my %what = ( next => $next, tagged => $tagged, score => $score ); my %what = ( next => $next, tagged => $tagged, score => $score );
$name .= join ' and ', (grep {$what{$_}} qw(next tagged score)); $name .= join ' and ', (grep {$what{$_}} qw(next tagged score));
$name .= " on page containing Section $pageSection->{variable}"; $name .= " on page containing Section $pageSection->{variable}" if $pageSection;
$name .= " Question $pageQuestion->{variable}" if $pageQuestion; $name .= " Question $pageQuestion->{variable}" if $pageQuestion;
} }
@ -502,7 +542,7 @@ sub _recordResponses {
responses => { type => HASHREF }, responses => { type => HASHREF },
surveyOrder => { type => ARRAYREF }, surveyOrder => { type => ARRAYREF },
surveyOrderIndexByVariableName => { type => HASHREF }, surveyOrderIndexByVariableName => { type => HASHREF },
next => 1, next => 0,
testCount => 1, testCount => 1,
name => 0, name => 0,
tagged => 0, tagged => 0,
@ -522,30 +562,32 @@ sub _recordResponses {
$rJSON->recordResponses($responses); $rJSON->recordResponses($responses);
# Check where we end up # Check where we end up, if asked
my $nextResponse = $rJSON->nextResponse; if ($next) {
my $nextAddress = $surveyOrder->[$nextResponse]; my $nextResponse = $rJSON->nextResponse;
my $nextSection = $rJSON->survey->section($nextAddress); my $nextAddress = $surveyOrder->[$nextResponse];
my $nextQuestion = $rJSON->survey->question($nextAddress); my $nextSection = $rJSON->survey->section($nextAddress);
# Get the lowest section surveyOrderIndex from lookup my $nextQuestion = $rJSON->survey->question($nextAddress);
my $got; # Get the lowest section surveyOrderIndex from lookup
my $svar = $nextSection->{variable}; my $got;
my $qvar = $nextQuestion->{variable}; my $svar = $nextSection->{variable};
if ($surveyOrderIndexByVariableName->{$svar} == $nextResponse) { my $qvar = $nextQuestion->{variable};
$got = "'$svar' (<-- a section)"; if ($surveyOrderIndexByVariableName->{$svar} == $nextResponse) {
$got .= " and '$qvar' (<-- a question)" if $qvar; $got = "'$svar' (<-- a section)";
} elsif ($qvar) { $got .= " and '$qvar' (<-- a question)" if $qvar;
$got = "'$qvar' (<-- a question)"; } elsif ($qvar) {
} else { $got = "'$qvar' (<-- a question)";
$got = 'Unknown!'; } else {
} $got = 'Unknown!';
my $expectedNextResponse = $surveyOrderIndexByVariableName->{$next}; }
if ($nextResponse != $expectedNextResponse) { my $expectedNextResponse = $surveyOrderIndexByVariableName->{$next};
return fail($testCount, $name, <<END_WHY); if ($nextResponse != $expectedNextResponse) {
return fail($testCount, $name, <<END_WHY);
Compared next section/question Compared next section/question
got : $got got : $got
expect : '$next' expect : '$next'
END_WHY END_WHY
}
} }
# Check tagged, if asked # Check tagged, if asked

74
t/Asset/Wobject/Survey/Test.t
View file

@ -21,7 +21,7 @@ my $session = WebGUI::Test->session;
#---------------------------------------------------------------------------- #----------------------------------------------------------------------------
# Tests # Tests
plan tests => 52; plan tests => 67;
my ( $s, $t1 ); my ( $s, $t1 );
@ -125,10 +125,50 @@ cmp_deeply(
$t1 = WebGUI::Asset::Wobject::Survey::Test->create( $session, { assetId => $s->getId } ); $t1 = WebGUI::Asset::Wobject::Survey::Test->create( $session, { assetId => $s->getId } );
my $spec; my $spec;
# No tests
$spec = <<END_SPEC;
[ ]
END_SPEC
try_it( $t1, $spec, { tap => <<END_TAP } );
1..0
END_TAP
# Empty defn
$spec = <<END_SPEC;
[ {} ]
END_SPEC
try_it( $t1, $spec, { tap => <<END_TAP } );
1..0
Bail Out! Invalid test definition
END_TAP
# Rubbish defn
$spec = <<END_SPEC;
[ { blah: 1 } ]
END_SPEC
try_it( $t1, $spec, { tap => <<END_TAP } );
1..0
Bail Out! Invalid test definition
END_TAP
###### ######
# test # test
###### ######
# No tests
$spec = <<END_SPEC;
[
{
"test" : { }
},
]
END_SPEC
try_it( $t1, $spec, { tap => <<END_TAP, fail => 1 } );
1..1
not ok 1 - Nothing to do
END_TAP
# Both answers for S0Q0 jump to the next item, which can be referred to as either S1 or S1Q0 # Both answers for S0Q0 jump to the next item, which can be referred to as either S1 or S1Q0
$spec = <<END_SPEC; $spec = <<END_SPEC;
[ [
@ -274,15 +314,15 @@ try_it( $t1, $spec, { tap => <<END_TAP } );
ok 1 - Checking next and tagged on page containing Section S0 Question S0Q0 ok 1 - Checking next and tagged on page containing Section S0 Question S0Q0
END_TAP END_TAP
# Use setup.. # Use page..
$spec = <<END_SPEC; $spec = <<END_SPEC;
[ [
{ {
"test" : { "test" : {
"setup" : { "S0Q0" : "Yes" }, # S0Q0 tagged 'tagged at S0Q0' "page" : { "S0Q0" : "Yes" }, # S0Q0 tagged 'tagged at S0Q0'
"S1Q0" : "No", "S1Q0" : "No",
"next" : "S2", "next" : "S2",
"tagged" : [ "tagged at S0Q0" ], # tagged by setup step "tagged" : [ "tagged at S0Q0" ], # tagged by page step
} }
}, },
] ]
@ -292,20 +332,20 @@ try_it( $t1, $spec, { tap => <<END_TAP } );
ok 1 - Checking next and tagged on page containing Section S1 Question S1Q0 ok 1 - Checking next and tagged on page containing Section S1 Question S1Q0
END_TAP END_TAP
# Use nested setup.. # Use nested page..
$spec = <<END_SPEC; $spec = <<END_SPEC;
[ [
{ {
"test" : { "test" : {
"setup" : { "page" : {
"setup" : { "page" : {
"S0Q0" : "Yes" # tagged 'tagged at S0Q0' "S0Q0" : "Yes" # tagged 'tagged at S0Q0'
}, },
"S1Q0" : "No", # tagged 'tagged at S1Q0' with value 999 "S1Q0" : "No", # tagged 'tagged at S1Q0' with value 999
}, },
"S2Q0" : null, "S2Q0" : null,
"next" : "S3", "next" : "S3",
"tagged" : [ "tagged at S0Q0", { "tagged at S1Q0" : 999 }, ], # tagged by setup step "tagged" : [ "tagged at S0Q0", { "tagged at S1Q0" : 999 }, ], # tagged by page step
} }
}, },
] ]
@ -334,6 +374,24 @@ try_it( $t1, $spec, { tap => <<END_TAP } );
ok 1 - Checking next and score on page containing Section S3 Question S3Q0 ok 1 - Checking next and score on page containing Section S3 Question S3Q0
END_TAP END_TAP
# Use the setup option
$spec = <<END_SPEC;
[
{
"test" : {
"S1Q0" : "n", # sets a tag of its own
"setup" : { tag: [ "my test tag", { "my data tag": 1.5 } ] },
"page" : { S0Q0: "y" }, # make sure this doesn't get overwritten
"tagged" : [ 'tagged at S0Q0', { 'tagged at S1Q0' : 999 }, "my test tag", { "my data tag": 1.5 } ],
}
},
]
END_SPEC
try_it( $t1, $spec, { tap => <<END_TAP } );
1..1
ok 1 - Checking tagged on page containing Section S1 Question S1Q0
END_TAP
######### #########
# test_mc # test_mc
######### #########