# TODO - Allow for messages to be functions
## defer to v2
# X - Allow for null input$answer
## No. If the quiz module wants a null value, it can provide a placeholder value that is not NULL
#' Tutorial quiz questions
#'
#' @description
#' Add interactive quiz questions to a tutorial. Each quiz question is executed
#' within a shiny runtime to provide more flexibility in the types of questions
#' offered. There are four default types of quiz questions:
#'
#' \describe{
#' \item{\code{learnr_radio}}{Radio button question. This question type will
#' only allow for a single answer submission by the user. An answer must be
#' marked for the user to submit their answer.}
#' \item{\code{learnr_checkbox}}{Check box question. This question type will
#' allow for one or more answers to be submitted by the user. At least one
#' answer must be marked for the user to submit their answer.}
#' \item{\code{learnr_text}}{Text box question. This question type will allow
#' for free form text to be submitted by the user. At least one non-whitespace
#' character must be added for the user to submit their answer.}
#' \item{\code{learnr_numeric}}{Numeric question. This question type will allow
#' for a number to be submitted by the user. At least one number must be added
#' for the user to submit their answer.}
#' }
#'
#' Note, the print behavior has changed as the runtime is now Shiny based. If
#' \code{question}s and \code{quiz}es are printed in the console, the S3
#' structure and information will be displayed.
#'
#'
#' @examples
#' quiz(
#' question("What number is the letter A in the alphabet?",
#' answer("8"),
#' answer("14"),
#' answer("1", correct = TRUE),
#' answer("23"),
#' incorrect = "See [here](https://en.wikipedia.org/wiki/English_alphabet) and try again.",
#' allow_retry = TRUE
#' ),
#'
#' question("Where are you right now? (select ALL that apply)",
#' answer("Planet Earth", correct = TRUE),
#' answer("Pluto"),
#' answer("At a computing device", correct = TRUE),
#' answer("In the Milky Way", correct = TRUE),
#' incorrect = paste0("Incorrect. You're on Earth, ",
#' "in the Milky Way, at a computer.")
#' )
#' )
#'
#' @param text Question or option text
#' @param ... One or more questions or answers
#' @param caption Optional quiz caption (defaults to "Quiz")
#' @param type Type of quiz question. Typically this can be automatically
#' determined based on the provided answers. Pass `"radio"` to indicate that
#' even though multiple correct answers are specified that inputs which
#' include only one correct answer are still correct. Pass `"checkbox"` to
#' force the use of checkboxes (as opposed to radio buttons) even though only
#' one correct answer was provided.
#' @param correct For `question`, text to print for a correct answer (defaults
#' to "Correct!"). For `answer`, a boolean indicating whether this answer is
#' correct.
#' @param incorrect Text to print for an incorrect answer (defaults to
#' "Incorrect") when `allow_retry` is `FALSE`.
#' @param try_again Text to print for an incorrect answer when `allow_retry`
#' is `TRUE`.
#' Defaults to "Incorrect. Be sure to select every correct answer." for
#' checkbox questions and "Incorrect" for non-checkbox questions.
#' @param message Additional message to display along with correct/incorrect
#' feedback. This message is always displayed after a question submission.
#' @param post_message Additional message to display along with
#' correct/incorrect feedback. If `allow_retry` is `TRUE`, this
#' message will only be displayed after the correct submission. If
#' `allow_retry` is `FALSE`, it will produce a second message
#' alongside the `message` message value.
#' @param loading Loading text to display as a placeholder while the question is
#' loaded. If not provided, generic "Loading..." or placeholder elements will
#' be displayed.
#' @param submit_button Label for the submit button. Defaults to `"Submit
#' Answer"`
#' @param try_again_button Label for the try again button. Defaults to `"Submit
#' Answer"`
#' @param allow_retry Allow retry for incorrect answers. Defaults to `FALSE`.
#' @param random_answer_order Display answers in a random order.
#' @param options Extra options to be stored in the question object. This is
#' useful when using custom question types. See [sortable::question_rank()]
#' for an example question implementation that uses the `options` parameter.
#'
#' @return A learnr quiz, or collection of questions.
#'
#' @family Interactive Questions
#' @seealso [random_praise()], [random_encouragement()]
#' @seealso For more information and question type extension examples, please
#' see the help documentation for [question_methods][question_ui_initialize()]
#' and view the \code{question_type} tutorial:
#' `learnr::run_tutorial("question_type", "learnr")`.
#' @name quiz
#' @rdname quiz
#' @export
quiz <- function(..., caption = rlang::missing_arg()) {
# create table rows from questions
index <- 1
questions <- lapply(list(...), function(question) {
if (!is.null(question$label)) {
label <- paste(question$label, index, sep="-")
question$label <- label
question$ids$answer <- NS(label)("answer")
question$ids$question <- label
index <<- index + 1
}
question
})
caption <-
if (rlang::is_missing(caption)) {
i18n_span("text.quiz", "Quiz")
} else if (!is.null(caption)) {
quiz_text(caption)
}
ret <- list(caption = caption, questions = questions)
class(ret) <- "tutorial_quiz"
ret
}
#' @rdname quiz
#' @import shiny
#' @export
question <- function(
text,
...,
type = c("auto", "single", "multiple", "learnr_radio", "learnr_checkbox", "learnr_text", "learnr_numeric"),
correct = "Correct!",
incorrect = "Incorrect",
try_again = NULL,
message = NULL,
post_message = NULL,
loading = NULL,
submit_button = rlang::missing_arg(),
try_again_button = rlang::missing_arg(),
allow_retry = FALSE,
random_answer_order = FALSE,
options = list()
) {
# one time tutor initialization
initialize_tutorial()
# capture/validate answers
rlang::check_dots_unnamed() # validate all answers are not named and not a misspelling
answers <- list(...)
lapply(answers, function(answer) {
checkmate::assert_class(answer, "tutorial_question_answer")
})
# verify chunk label if necessary
verify_tutorial_chunk_label()
# count total correct answers to decide between radio/checkbox
answers_split <- answers_split_type(answers)
total_correct <- sum(vapply(answers_split[["literal"]], `[[`, logical(1), "correct"))
# determine or resolve question type
if (missing(type)) {
# no partial matching for s3 methods means we can't use match.arg()
type <- "auto"
}
if (identical(type, "auto")) {
if (total_correct > 1) {
type <- "learnr_checkbox"
} else {
type <- "learnr_radio"
}
}
if (length(type) == 1) {
type <- switch(type,
"radio" = ,
"single" = "learnr_radio",
"checkbox" = ,
"multiple" = "learnr_checkbox",
# allows for s3 methods
type
)
}
if (is.null(try_again)) {
try_again <- if (identical(type, "learnr_checkbox")) {
"Incorrect. Be sure to select every correct answer."
} else {
incorrect
}
}
# ensure we have at least one correct answer, if required
must_have_correct <- identical(type, "learnr_radio") || is.null(answers_split[["function"]])
if (must_have_correct && total_correct == 0) {
stop("At least one correct answer must be supplied")
}
# can not guarantee that `label` exists
label <- knitr::opts_current$get('label')
q_id <- label %||% random_question_id()
# i18nize button labels if default values are used
submit_button <-
if (rlang::is_missing(submit_button)) {
i18n_span("button.questionsubmit", "Submit Answer")
} else {
quiz_text(submit_button)
}
try_again_button <-
if (rlang::is_missing(try_again_button)) {
i18n_span("button.questiontryagain", "Try Again")
} else {
quiz_text(try_again_button)
}
ret <- list(
type = type,
label = label,
question = quiz_text(text),
answers = answers,
button_labels = list(
submit = submit_button,
try_again = try_again_button
),
messages = list(
correct = quiz_text(correct),
try_again = quiz_text(try_again),
incorrect = quiz_text(incorrect),
message = quiz_text(message),
post_message = quiz_text(post_message)
),
ids = list(
answer = NS(q_id)("answer"),
question = q_id
),
loading = if (!is.null(loading)) quiz_text(loading),
random_answer_order = random_answer_order,
allow_retry = allow_retry,
# Set a seed for local testing, even though it is overwritten for each shiny session
seed = random_seed(),
options = options
)
class(ret) <- c(type, "tutorial_question")
ret
}
# render markdown (including equations) for quiz_text
quiz_text <- function(text) {
if (is_html_chr(text) || is_html_tag(text)) {
return(text)
}
if (!is.null(text)) {
if (!is.character(text)) {
text <- format(text)
}
# convert markdown
md <- markdown::mark(text = text)
if (length(str_match_all(md, "</p>", fixed = TRUE)) == 1) {
# remove leading and trailing paragraph
md <- sub("^<p>", "", md)
md <- sub("</p>\n?$", "", md)
}
HTML(md)
}
else {
NULL
}
}
random_id <- function(txt) {
paste0(txt, "_", as.hexmode(floor(runif(1, 1, 16^7))))
}
random_question_id <- function() {
random_id("lnr_ques")
}
random_seed <- function() {
stats::runif(1, 0, .Machine$integer.max)
}
shuffle <- function(x) {
sample(x, length(x))
}
#' Knitr quiz print methods
#'
#' \code{knitr::\link[knitr]{knit_print}} methods for \code{\link{question}} and
#' \code{\link{quiz}}
#'
#' @inheritParams knitr::knit_print
#'
#' @importFrom knitr knit_print
#' @method knit_print tutorial_question
#' @export
#' @rdname knit_print
knit_print.tutorial_question <- function(x, ...) {
question <- x
ui <- question_module_ui(question$ids$question)
# too late to try to set a chunk attribute
# knitr::set_chunkattr(echo = FALSE)
rmarkdown::shiny_prerendered_chunk(
'server',
sprintf(
'learnr:::question_prerendered_chunk(%s, session = session)',
dput_to_string(question)
)
)
# regular knit print the UI
knitr::knit_print(ui)
}
#' @method knit_print tutorial_quiz
#' @export
#' @rdname knit_print
knit_print.tutorial_quiz <- function(x, ...) {
quiz <- x
caption_tag <- if (!is.null(quiz$caption)) {
list(knitr::knit_print(
tags$div(class = "panel-heading tutorial-quiz-title", quiz$caption)
))
}
append(
caption_tag,
lapply(quiz$questions, knitr::knit_print)
)
}
retrieve_all_question_submissions <- function(session) {
state_objects <- get_all_state_objects(session, exercise_output = FALSE)
# create submissions from state objects
submissions <- submissions_from_state_objects(state_objects)
submissions
}
retrieve_question_submission_answer <- function(session, question_label) {
question_label <- as.character(question_label)
for (submission in retrieve_all_question_submissions(session)) {
if (identical(as.character(submission$id), question_label)) {
return(submission$data$answer)
}
}
return(NULL)
}
question_prerendered_chunk <- function(question, ..., session = getDefaultReactiveDomain()) {
store_question_cache(question)
question_state <-
callModule(
question_module_server,
question$ids$question,
question = question,
session = session
)
observe({
req(question_state())
set_tutorial_state(question$label, question_state(), session = session)
})
question_state
}
question_module_ui <- function(id) {
ns <- NS(id)
div(
class = "panel panel-default tutorial-question-container",
div(
"data-label" = as.character(id),
class = "tutorial-question panel-body",
uiOutput(ns("answer_container")),
uiOutput(ns("message_container")),
uiOutput(ns("action_button_container")),
withLearnrMathJax()
)
)
}
question_module_server <- function(
input, output, session,
question
) {
output$answer_container <- renderUI({
if (is.null(question$loading)) {
question_ui_loading(question)
} else {
div(
class="loading",
question$loading
)
}
})
# Setup reactive here that will be updated by the question modules
question_state <- reactiveVal()
observeEvent(
req(session$userData$learnr_state() == "restored"),
once = TRUE,
question_module_server_impl(input, output, session, question, question_state)
)
question_state
}
question_module_server_impl <- function(
input, output, session,
question,
question_state = NULL
) {
ns <- getDefaultReactiveDomain()$ns
# set a seed for each user session for question methods to use
question$seed <- random_seed()
# only set when a submit button has been pressed
# (or reset when try again is hit)
# (or set when restoring)
submitted_answer <- reactiveVal(NULL, label = "submitted_answer")
is_correct_info <- reactive(label = "is_correct_info", {
# question has not been submitted
if (is.null(submitted_answer())) return(NULL)
# find out if answer is right
ret <- question_is_correct(question, submitted_answer())
if (!inherits(ret, "learnr_mark_as")) {
stop("`question_is_correct(question, input$answer)` must return a result from `correct`, `incorrect`, or `mark_as`")
}
ret
})
# should present all messages?
is_done <- reactive(label = "is_done", {
if (is.null(is_correct_info())) return(NULL)
(!isTRUE(question$allow_retry)) || is_correct_info()$correct
})
button_type <- reactive(label = "button type", {
if (is.null(submitted_answer())) {
"submit"
} else {
# is_correct_info() should be valid
if (is.null(is_correct_info())) {
stop("`is_correct_info()` is `NULL` in a place it shouldn't be")
}
# update the submit button label
if (is_correct_info()$correct) {
"correct"
} else {
# not correct
if (isTRUE(question$allow_retry)) {
# not correct, but may try again
"try_again"
} else {
# not correct and can not try again
"incorrect"
}
}
}
})
# disable / enable for every input$answer change
answer_is_valid <- reactive(label = "answer_is_valid", {
if (is.null(submitted_answer())) {
question_is_valid(question, input$answer)
} else {
question_is_valid(question, submitted_answer())
}
})
init_question <- function(restoreValue = NULL) {
if (question$random_answer_order) {
# Shuffle visible answer options (i.e. static, non-function answers)
is_visible_option <- !answer_type_is_function(question$answers)
question$answers[is_visible_option] <<- shuffle(question$answers[is_visible_option])
}
submitted_answer(restoreValue)
}
# restore past submission
# If no prior submission, it returns NULL
past_submission_answer <- retrieve_question_submission_answer(session, question$label)
# initialize like normal... nothing has been submitted
# or
# initialize with the past answer
# this should cascade throughout the app to display correct answers and final outputs
init_question(past_submission_answer)
output$action_button_container <- renderUI({
question_button_label(
question,
button_type(),
answer_is_valid()
)
})
output$message_container <- renderUI({
req(!is.null(is_correct_info()), !is.null(is_done()))
withLearnrMathJax(
question_messages(
question,
messages = is_correct_info()$messages,
is_correct = is_correct_info()$correct,
is_done = is_done()
)
)
})
output$answer_container <- renderUI({
if (is.null(submitted_answer())) {
# has not submitted, show regular answers
return(
# if there is an existing input$answer, display it.
# if there is no answer... init with NULL
# Do not re-render the UI for every input$answer change
withLearnrMathJax(
question_ui_initialize(question, isolate(input$answer))
)
)
}
# has submitted
if (is.null(is_done())) {
# has not initialized
return(NULL)
}
if (is_done()) {
# if the question is 'done', display the final input ui and disable everything
return(
withLearnrMathJax(
question_ui_completed(question, submitted_answer())
)
)
}
# if the question is NOT 'done', disable the current UI
# until it is reset with the try again button
return(
withLearnrMathJax(
question_ui_try_again(question, submitted_answer())
)
)
})
observeEvent(input$action_button, {
if (button_type() == "try_again") {
# maintain current submission / do not randomize answer order
# only reset the submitted answers
# does NOT reset input$answer
submitted_answer(NULL)
# submit "reset" to server
event_trigger(
session,
"reset_question_submission",
data = list(
label = as.character(question$label),
question = as.character(question$question)
)
)
return()
}
submitted_answer(input$answer)
# submit question to server
event_trigger(
session = session,
event = "question_submission",
data = list(
label = as.character(question$label),
question = as.character(question$question),
answer = as.character(input$answer),
correct = is_correct_info()$correct
)
)
})
observe({
# Update the `question_state()` reactive to report state back to the Shiny session
req(submitted_answer(), is.reactive(question_state))
current_answer_state <- list(
type = "question",
answer = submitted_answer(),
correct = is_correct_info()$correct
)
question_state(current_answer_state)
})
}
question_button_label <- function(question, label_type = "submit", is_valid = TRUE) {
label_type <- match.arg(label_type, c("submit", "try_again", "correct", "incorrect"))
if (label_type %in% c("correct", "incorrect")) {
# No button when answer is correct or incorrect (wrong without try again)
return(NULL)
}
button_label <- question$button_labels[[label_type]]
is_valid <- isTRUE(is_valid)
default_class <- "btn-primary"
warning_class <- "btn-warning"
action_button_id <- NS(question$ids$question)("action_button")
if (label_type == "submit") {
button <- actionButton(
action_button_id, button_label,
class = default_class
)
if (!is_valid) {
button <- disable_all_tags(button)
}
button
} else if (label_type == "try_again") {
mutate_tags(
actionButton(
action_button_id, button_label,
class = warning_class
),
paste0("#", action_button_id),
function(ele) {
ele$attribs$class <- str_remove(ele$attribs$class, "\\s+btn-default")
ele
}
)
}
}
question_messages <- function(question, messages, is_correct, is_done) {
# Always display the incorrect, correct, or try again messages
default_message <-
if (is_correct) {
question$messages$correct
} else {
# not correct
if (is_done) {
question$messages$incorrect
} else {
question$messages$try_again
}
}
if (!is.null(messages)) {
if (!is.list(messages)) {
# turn vectors into lists
messages <- tagList(messages)
}
}
# display the default messages first
if (!is.null(default_message)) {
if (!is.null(messages)) {
messages <- tagList(default_message, messages)
} else {
messages <- default_message
}
}
# get regular message
if (is.null(messages)) {
message_alert <- NULL
} else {
alert_class <- if (is_correct) "alert-success" else "alert-danger"
if (length(messages) > 1) {
# add breaks inbetween similar messages
break_tag <- list(tags$br(), tags$br())
all_messages <- replicate(length(messages) * 2 - 1, {break_tag}, simplify = FALSE)
# store in all _odd_ positions
all_messages[(seq_along(messages) * 2) - 1] <- messages
messages <- tagList(all_messages)
}
message_alert <- tags$div(
class = paste0("alert ", alert_class),
messages
)
}
if (is.null(question$messages$message)) {
always_message_alert <- NULL
} else {
always_message_alert <- tags$div(
class = "alert alert-info",
question$messages$message
)
}
# get post question message only if the question is done
if (isTRUE(is_done) && !is.null(question$messages$post_message)) {
post_alert <- tags$div(
class = "alert alert-info",
question$messages$post_message
)
} else {
post_alert <- NULL
}
# set UI message
if (all(
is.null(message_alert),
is.null(always_message_alert),
is.null(post_alert)
)) {
NULL
} else {
htmltools::tagList(message_alert, always_message_alert, post_alert)
}
}
question_ui_loading <- function(question) {
prompt <- format(question$question)
n_paragraphs <- max(length(str_match_all(prompt, "</p>")), 1)
paras <- lapply(seq_len(n_paragraphs), function(...) {
spans <- lapply(seq_len(sample(2:4, 1)), function(...) {
htmltools::span(class = sprintf("placeholder col-%s", sample(2:7, 1)))
})
htmltools::p(spans)
})
q_opts <- NULL
if (length(intersect(question$type, c("learnr_radio", "learnr_checkbox"))) > 0) {
q_opts <- htmltools::tags$ul(
lapply(seq_along(question$answers), function(...) {
htmltools::tags$li(
htmltools::span(class = "placeholder col-3")
)
})
)
}
button <- htmltools::tags$a(
href = "#",
tabindex = "-1",
class = "btn btn-primary disabled placeholder col-3",
`aria-hidden` = "true"
)
htmltools::div(
class = "loading placeholder-glow",
paras,
q_opts,
button
)
}
withLearnrMathJax <- function(...) {
htmltools::tagList(
...,
htmltools::tags$script(
# only attempt function if it exists
htmltools::HTML("if (Tutorial.triggerMathJax) Tutorial.triggerMathJax()")
)
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.