R/question_model.R

In MichielNoback/bintestr: The BioINformatics automated TESTing environment for R

#### QUESTION TESTER

new_QuestionTester <- function(tester_function, feedback_generator) {
    stopifnot(is.function(tester_function))
    stopifnot(is.function(feedback_generator) || is.character(feedback_generator))
    qt_data <- list(feedback_message = "FEEDBACK", answer_correct = FALSE)
    check_answer <- function(answer) {
        if (tester_function(answer)){
            qt_data$feedback_message <<- "That is correct!"
            qt_data$answer_correct <<- TRUE
        }
        else {
            if (is.character(feedback_generator)) qt_data$feedback_message <<- feedback_generator
            else qt_data$feedback_message <<- feedback_generator(answer)
        }
    }
    verify <- function() {
        if (tester_function()){
            qt_data$feedback_message <<- "That is correct!"
            qt_data$answer_correct <<- TRUE
        }
        else {
            if (is.character(feedback_generator)) qt_data$feedback_message <<- feedback_generator
            else qt_data$feedback_message <<- feedback_generator()
        }
    }
    correct <- function() qt_data$answer_correct
    message <- function() qt_data$feedback_message

    t <- list(check_answer = check_answer, is_correct = correct, verify = verify, message = message)
    structure(t, class="QuestionTester")
}

#' QuestionTester constructor
#'
#' This S3 class should be instantiated and passed to the Question constructor.
#' It will be used to verify the users' answer and also provide feedback when a
#' given answer is incorrect.
#'
#' @param tester_fun the function that will be called to verify the question answer.
#' It should only return \code{TRUE} or \code{FALSE}
#' @param feedback_generator this argument is used to rovide relevant feedback
#' to the user. It can be either a simple \code{character} or a \code{function}.
#' If it is a character, it is simply displayed when the answer is incorrect.
#' If it is a function, it will be called when \code{tester} returns
#' \code{FALSE}. It will be passed the user's incorrect answer and should print some
#' appropriate feedback message.
#'
#' @examples
#' ## Instantiate a QuestionTester that tests for a character vector with a single
#' ## "word" of length 5
#' ## The feedback_generator generates some appropriate messages depending on the answer
#' t1 <- QuestionTester(
#'     function(x){is.character(x) && length(x)==1 && nchar(x)==5},
#'     function(x){
#'         if(! is.character(x)) "that is no word"
#'         else if(nchar(x) < 5) paste0(x, " has ", nchar(x), " characters and that is not 5")
#'     }
#' )
#' q1 <- Question("Please give a word of length 5", t1)
#'
#' @export
QuestionTester <- function(tester_function, feedback_generator) {
    new_QuestionTester(tester_function, feedback_generator)
}


#### QUESTION
new_Question <- function(q_text, q_tester, q_type, hints) {
    stopifnot(is.character(q_text))
    stopifnot(class(q_tester) == "QuestionTester" )
    stopifnot(is.character(q_type))
    stopifnot(is.list(hints))
    hint_index = 0
    max_hints = length(hints)
    ask <- function(){
        message(q_text)
        if (q_type == "console-input") {
           while (! q_tester$is_correct()) {
                answer <- readline("")
                if(nchar(answer) == 0) {
                    message("It seems you want to quit this question. A shame.")
                }
                q_tester$check_answer(answer)
                message(q_tester$message())
                if (! q_tester$is_correct()) {
                    hint()
                }
            }
        } else if (q_type == "environment-eval") {
            message("  (call verify() on the Question object to check your result)")
        }
    }
    verify <- function() {
        q_tester$verify()
        message(q_tester$message())
        if (!q_tester$is_correct()) hint()
    }
    hint <- function() {
        hint_index <<- hint_index + 1
        if(hint_index > max_hints) {
            message("Sorry, no more hints")
        } else {
            message(paste0("  Hint: ", hints[[hint_index]]))
        }
    }
    q <- list(ask = ask,
              text = q_text,
              tester = q_tester,
              verify = verify,
              hint = hint)
    structure(q, class="Question")
}

#' Question constructor
#'
#' This S3 class encapsulates a question for interactive lesson scenarios.
#'
#' @param q_text the text that will be displayed in the console prompting the user
#' to action.
#'
#' @param q_tester an instance of class \link[bintestr]{QuestionTester}.
#'
#' @param q_type the type can be one of \code{console-input}, \code{environment-eval}. For
#' \code{console-input}, execution will be halted until the user has entered some text
#' and hit enter. For \code{environment-eval}, the user is required to explicitly call
#' \code{verify()} on the question instance.
#'
#' @param hints a list of hints that will be displayed in consecutive order for each
#' incorrect answer.
#'
#' @examples
#' ## Instantiate a QuestionTester that tests for a character vector with a single
#' ## "word" of length 5
#' ## The feedback_generator generates some appropriate messages depending on the answer
#' t1 <- QuestionTester(
#'     function(x){is.character(x) && length(x)==1 && nchar(x)==5},
#'     function(x){
#'         if(! is.character(x)) "that is no word"
#'         else if(nchar(x) < 5) paste0(x, " has ", nchar(x), " characters and that is not 5")
#'     }
#' )
#' q1 <- Question("Please give a word of length 5", t1)
#'
#' @export
Question <- function(q_text, q_tester, q_type="console-input", hints = NULL) {
    if(is.null(hints)) hints <- list("Hints have no power here")

    new_Question(q_text, q_tester, q_type, hints)
}