diff --git a/NAMESPACE b/NAMESPACE index e1995ca9c..cf1c9a95e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,6 +28,7 @@ export(initialize_tutorial) export(mark_as) export(one_time) export(question) +export(question_anybox) export(question_checkbox) export(question_is_correct) export(question_is_valid) diff --git a/NEWS.md b/NEWS.md index ce9381290..4433e41d9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -18,6 +18,7 @@ learnr (development version) * Added an event handler system, with the functions `event_register_handler()` and `one_time()`. There is also a new event `"section_viewed"`, which is triggered when a new section becomes visible. ([#398](https://github.com/rstudio/learnr/pull/398)) * Previously, when a question submission was reset, it would be recorded as a `"question_submission"` event with the value `reset=TRUE`. Now it a separate event, `"reset_question_submission"`. ([#398](https://github.com/rstudio/learnr/pull/398)) * Added a new `polyglot` tutorial to learnr. This tutorial displays mixing R, python, and sql exercises. See [`run_tutorial("polyglot", "learnr")`](https://learnr-examples.shinyapps.io/polyglot) for a an example. ([#397](https://github.com/rstudio/learnr/pull/397)) +* Added a new `anybox` question type which allows for partially correct checkbox questions to be evaluated as correct. ([#382](https://github.com/rstudio/learnr/pull/382)) ## Minor new features and improvements diff --git a/R/question_anybox.R b/R/question_anybox.R new file mode 100644 index 000000000..8b3fac5fc --- /dev/null +++ b/R/question_anybox.R @@ -0,0 +1,131 @@ +#' Anybox question +#' +#' Creates an anybox group tutorial quiz question. The student may select one +#' or more checkboxes before submitting their answer. An alternative to the +#' checkbox group tutorial quiz question, if there are multiple correct answers, +#' you may choose the minimum number of correct responses and the maximum number +#' of incorrect responses required to successfully complete the question. +#' +#' Correct options should have a message which will display if the question is +#' passed with missed options. +#' +#' +#' @inheritParams question +#' @param min_right Minimum number of correct options which must be selected. +#' @param max_wrong Maximum number of incorrect options which may be selected. +#' @param ... answers and extra parameters passed onto \code{\link{question}}. +#' @seealso \code{\link{question_checkbox}} \code{\link{question_radio}}, +#' \code{\link{question_text}} +#' @export +#' @examples +#' question_anybox( +#' "Select at least two toppings that belong on a Margherita Pizza (and no more than one that doesn't):", +#' answer("tomato", correct = TRUE, message = "Tomatoes too!"), +#' answer("mozzarella", correct = TRUE, message = "Don't forget the cheese!"), +#' answer("basil", correct = TRUE, message = "Basil gives it a distinctive flavor!"), +#' answer("extra virgin olive oil", correct = TRUE, message = "You need olive oil too!"), +#' answer("pepperoni", message = "Pepperoni is a great topping! ... just not on a Margherita Pizza"), +#' answer("onions", message = "Onions!? No and yuck!"), +#' answer("bacon", message = "Bacon doesn't belong here!"), +#' answer("spinach", message = "Spinach? With Olive Oil? Only if you're Popeye!"), +#' random_answer_order = TRUE, +#' allow_retry = TRUE, +#' try_again = "Be sure to select all four toppings!", +#' min_right = 2, +#' max_wrong = 1 +#' ) +question_anybox <- function( + text, + ..., + correct = "Correct!", + incorrect = "Incorrect", + try_again = incorrect, + allow_retry = FALSE, + random_answer_order = FALSE, + min_right = 1, + max_wrong = 0 +) { + structure(learnr::question( + text = text, + ..., + type = "learnr_anybox", + correct = correct, + incorrect = incorrect, + allow_retry = allow_retry, + random_answer_order = random_answer_order + ), min_right = min_right, max_wrong = max_wrong) +} + + +question_ui_initialize.learnr_anybox <- function(question, value, ...) { + choice_names <- answer_labels(question) + choice_values <- answer_values(question) + checkboxGroupInput( + question$ids$answer, + label = question$question, + choiceNames = choice_names, + choiceValues = choice_values, + selected = value + ) +} + +question_is_correct.learnr_anybox <- function(question, value, ...) { + append_message <- function(x, ans) { + message <- ans$message + if (is.null(message)) { + return(x) + } + if (length(x) == 0) { + message + } else { + tagList(x, message) + } + } + + min_right <- max(attr(question, "min_right"), 1) + max_wrong <- max(attr(question, "max_wrong"), 0) + ans <- question[["answers"]] + anss <- vapply(ans, `[[`, character(1), "option") + corr <- vapply(ans, `[[`, logical(1), "correct") + cor_ans <- anss[corr] + check <- match(value, cor_ans) + right <- cor_ans[stats::na.omit(check)] + wrong <- ans[match(setdiff(value, cor_ans), anss)] + missed <- ans[match(setdiff(cor_ans, value), anss)] + ret_messages <- NULL + pass <- length(right) >= min_right && length(wrong) <= max_wrong + if (pass) { + for (miss in missed) { + ret_messages <- append_message(ret_messages, miss) + } + for (bad in wrong) { + ret_messages <- append_message(ret_messages, bad) + } + } + mark_as(pass, ret_messages) +} + +question_ui_completed.learnr_anybox <- function(question, value, ...) { + choice_values <- answer_values(question) + # update select answers to have X or √ + choice_names_final <- lapply(question$answers, function(ans) { + if (ans$correct) { + tag <- " ✓ " + tagClass <- "correct" + } else { + tag <- " ✗ " + tagClass <- "incorrect" + } + tags$span(ans$label, HTML(tag), class = tagClass) + }) + + disable_all_tags( + checkboxGroupInput( + question$ids$answer, + label = question$question, + choiceValues = choice_values, + choiceNames = choice_names_final, + selected = value + ) + ) +} diff --git a/man/question_anybox.Rd b/man/question_anybox.Rd new file mode 100644 index 000000000..002c83b9a --- /dev/null +++ b/man/question_anybox.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/question_anybox.R +\name{question_anybox} +\alias{question_anybox} +\title{Anybox question} +\usage{ +question_anybox( + text, + ..., + correct = "Correct!", + incorrect = "Incorrect", + try_again = incorrect, + allow_retry = FALSE, + random_answer_order = FALSE, + min_right = 1, + max_wrong = 0 +) +} +\arguments{ +\item{text}{Question or option text} + +\item{...}{answers and extra parameters passed onto \code{\link{question}}.} + +\item{correct}{For \code{question}, text to print for a correct answer (defaults +to "Correct!"). For \code{answer}, a boolean indicating whether this answer is +correct.} + +\item{incorrect}{Text to print for an incorrect answer (defaults to "Incorrect") +when \code{allow_retry} is \code{FALSE}.} + +\item{try_again}{Text to print for an incorrect answer (defaults to "Incorrect") +when \code{allow_retry} is \code{TRUE}.} + +\item{allow_retry}{Allow retry for incorrect answers. Defaults to \code{FALSE}.} + +\item{random_answer_order}{Display answers in a random order.} + +\item{min_right}{Minimum number of correct options which must be selected.} + +\item{max_wrong}{Maximum number of incorrect options which may be selected.} +} +\description{ +Creates an anybox group tutorial quiz question. The student may select one +or more checkboxes before submitting their answer. An alternative to the +checkbox group tutorial quiz question, if there are multiple correct answers, +you may choose the minimum number of correct responses and the maximum number +of incorrect responses required to successfully complete the question. +} +\details{ +Correct options should have a message which will display if the question is +passed with missed options. +} +\examples{ +question_anybox( + "Select at least two toppings that belong on a Margherita Pizza (and no more than one that doesn't):", + answer("tomato", correct = TRUE, message = "Tomatoes too!"), + answer("mozzarella", correct = TRUE, message = "Don't forget the cheese!"), + answer("basil", correct = TRUE, message = "Basil gives it a distinctive flavor!"), + answer("extra virgin olive oil", correct = TRUE, message = "You need olive oil too!"), + answer("pepperoni", message = "Pepperoni is a great topping! ... just not on a Margherita Pizza"), + answer("onions", message = "Onions!? No and yuck!"), + answer("bacon", message = "Bacon doesn't belong here!"), + answer("spinach", message = "Spinach? With Olive Oil? Only if you're Popeye!"), + random_answer_order = TRUE, + allow_retry = TRUE, + try_again = "Be sure to select all four toppings!", + min_right = 2, + max_wrong = 1 +) +} +\seealso{ +\code{\link{question_checkbox}} \code{\link{question_radio}}, +\code{\link{question_text}} +} diff --git a/tests/testthat/test-question-anybox.R b/tests/testthat/test-question-anybox.R new file mode 100644 index 000000000..7cceb73e8 --- /dev/null +++ b/tests/testthat/test-question-anybox.R @@ -0,0 +1,41 @@ + + +context("question-checkbox") + +test_that("correct messages are not included", { + + q <- question_anybox( + "test", + answer("A", correct = TRUE, message = "msg **1**"), + answer("B", correct = TRUE, message = "msg _2_"), + answer("C", correct = TRUE, message = "msg **3**"), + answer("D", correct = FALSE, message = "msg _4_"), + answer("E", correct = FALSE, message = "msg **5**"), + min_right = 2, + max_wrong = 1 + ) + + ans <- question_is_correct(q, c("A", "B", "D")) + + expect_equivalent(ans$correct, TRUE) + expect_equivalent(as.character(ans$messages), + "msg 3\nmsg 4") + + + ans <- question_is_correct(q, c("A", "B", "D", "E")) + expect_equivalent(ans$correct, FALSE) + expect_equivalent(as.character(ans$messages), character(0)) + + ans <- question_is_correct(q, c("A", "E")) + expect_equivalent(ans$correct, FALSE) + expect_equivalent(as.character(ans$messages), character(0)) + + ans <- question_is_correct(q, c("A", "B")) + expect_equivalent(ans$correct, TRUE) + expect_equivalent(as.character(ans$messages), "msg 3") + + ans <- question_is_correct(q, c("A", "B", "C")) + expect_equivalent(ans$correct, TRUE) + expect_equivalent(as.character(ans$messages), character(0)) + +})