Add new anybox question type to solve #382

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)

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
 

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 <- " &#10003; "
+      tagClass <- "correct"
+    } else {
+      tag <- " &#10007; "
+      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
+    )
+  )
+}

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 <strong>3</strong>\nmsg <em>4</em>")
+
+
+  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 <strong>3</strong>")
+
+  ans <- question_is_correct(q, c("A", "B", "C"))
+  expect_equivalent(ans$correct, TRUE)
+  expect_equivalent(as.character(ans$messages), character(0))
+
+})