tests/testthat/test-question_checkbox.R

In learnr: Interactive Tutorials for R

test_that("question_checkbox() does not include correct messages for incorrect answer", {

  q <- question_checkbox(
    "test",
    answer("A", correct = TRUE, message = "msg **1**"),
    answer("B", correct = TRUE, message = "msg _2_"),
    answer("C", correct = FALSE, message = "msg **3**"),
    answer("D", correct = FALSE, message = "msg _4_"),
    answer("E", correct = FALSE, message = "msg **5**"),
    answer("F", correct = FALSE)
  )

  ans <- question_is_correct(q, c("A", "B", "C"))

  expect_marked_as(ans, correct = FALSE, messages = quiz_text("msg **3**"))

  ans <- question_is_correct(q, c("A", "B", "C", "D"))
  expect_marked_as(
    ans,
    correct = FALSE,
    messages = list(quiz_text("msg **3**"), quiz_text("msg _4_"))
  )

  ans <- question_is_correct(q, c("A"))
  expect_marked_as(ans, correct = FALSE, messages = NULL)

  ans <- question_is_correct(q, c("A", "B"))
  expect_marked_as(
    ans,
    correct = TRUE,
    messages = list(quiz_text("msg **1**"), quiz_text("msg _2_"))
  )

  expect_marked_as(question_is_correct(q, "F"), correct = FALSE)
})

test_that("question_checkbox() message depends on whether allow_retry = TRUE", {

  incorrect_message <- "incorrect"
  try_again_message <- "try_again"

  q <- question_checkbox(
    "test",
    answer("A", correct = TRUE),
    answer("B", correct = TRUE),
    answer("C", correct = FALSE),
    incorrect = incorrect_message,
    try_again = try_again_message
  )

  out_no_retry <- question_messages(
    question = q,
    messages = NULL,
    is_correct = FALSE,
    is_done = TRUE
  )
  expect_equal(as.character(out_no_retry[[1]]$children[[1]]), incorrect_message)

  out_retry <- question_messages(
    question = q,
    messages = NULL,
    is_correct = FALSE,
    is_done = FALSE
  )
  expect_equal(as.character(out_retry[[1]]$children[[1]]), try_again_message)
})

test_that("question_checkbox() evaluates function answers first", {
  q <- question_checkbox(
    "test",
    answer("A", TRUE, "a"),
    answer("B", TRUE, "b"),
    answer("C", FALSE, "c"),
    answer_fn(function(value) {
      if (identical(value, c("B", "C"))) {
        mark_as(FALSE, "B + C is special")
      }
    })
  )

  response <- question_is_correct(q, c("C"))
  expect_marked_as(response, FALSE, quiz_text("c"))

  response <- question_is_correct(q, c("A", "C"))
  expect_marked_as(response, FALSE, quiz_text("c"))

  response <- question_is_correct(q, c("B", "C"))
  expect_marked_as(response, FALSE, "B + C is special")

  response <- question_is_correct(q, c("B", "A"))
  expect_marked_as(response, TRUE, list(quiz_text("a"), quiz_text("b")))
})