Colin/output styles

R/exercise.R

@@ -15,7 +15,6 @@ setup_exercise_handler <- function(exercise_rx, session) {
 
   # observe input
   observeEvent(exercise_rx(), {
-
     # get exercise
     exercise <- exercise_rx()
 
@@ -187,7 +186,7 @@ evaluate_exercise <- function(exercise, envir, evaluate_global_setup = FALSE) {
   # do not consider this an exercise submission
   if (!nzchar(str_trim(paste0(exercise$code, collapse = "\n")))) {
     # " " since html_output needs to pass a req()
-    return(exercise_result(html_output = " "))
+    return(exercise_result(html_output = " ", exercise = NULL))
   }
 
   if (evaluate_global_setup) {
@@ -239,9 +238,11 @@ evaluate_exercise <- function(exercise, envir, evaluate_global_setup = FALSE) {
   }
 
   # include any checker feedback with the exercise results
+
   exercise_result(
     feedback = checker_feedback$feedback,
-    html_output = rmd_results$html_output
+    html_output = rmd_results$html_output,
+    exercise = exercise
   )
 }
 
@@ -253,7 +254,10 @@ try_checker <- function(exercise, name, check_code, envir_result,
     get_checker_func(exercise, name, envir_prep),
     error = function(e) {
       message("Error occured while retrieving 'exercise.checker'. Error:\n", e)
-      exercise_result_error(e$message)
+      exercise_result_error(
+        e$message,
+        exercise = exercise
+      )
     }
   )
   # If retrieving checker_func fails, return an error result
@@ -280,7 +284,7 @@ try_checker <- function(exercise, name, check_code, envir_result,
       name, paste(missing_args, collapse = "', '")
     )
     message(msg)
-    return(exercise_result_error(msg))
+    return(exercise_result_error(msg, exercise = exercise))
   }
 
   # Call the check function
@@ -289,7 +293,7 @@ try_checker <- function(exercise, name, check_code, envir_result,
     error = function(e) {
       msg <- paste("Error occurred while evaluating", sprintf("'%s'", name))
       message(msg, ": ", conditionMessage(e))
-      exercise_result_error(msg)
+      exercise_result_error(msg, exercise = exercise)
     }
   )
   # If checker code fails, return an error result
@@ -298,7 +302,7 @@ try_checker <- function(exercise, name, check_code, envir_result,
   }
   # If checker doesn't return anything, there's no exercise result to return
   if (length(feedback)) {
-    exercise_result(feedback)
+    exercise_result(feedback, exercise = exercise)
   } else {
     feedback
   }
@@ -395,7 +399,7 @@ render_exercise <- function(exercise, envir, envir_prep) {
     # make the time limit error message a bit more friendly
     pattern <- gettext("reached elapsed time limit", domain = "R")
     if (grepl(pattern, msg, fixed = TRUE)) {
-      return(exercise_result_timeout())
+      return(exercise_result_timeout(exercise = exercise))
     }
     if (length(exercise$error_check)) {
       # Run the condition through an error checker (the exercise could be to throw an error!)
@@ -412,7 +416,7 @@ render_exercise <- function(exercise, envir, envir_prep) {
         return(checker_feedback)
       }
     }
-    exercise_result_error(msg)
+    exercise_result_error(msg, exercise = exercise)
   })
 
   if (is_exercise_result(output_file)) {
@@ -436,8 +440,9 @@ render_exercise <- function(exercise, envir, envir_prep) {
       message = "The submitted code didn't produce a visible value, so exercise checking may not work correctly.",
       type = "warning", correct = FALSE
     )
+
     html_output <- htmltools::tagList(
-      feedback_as_html(invisible_feedback),
+      feedback_as_html(invisible_feedback, exercise = exercise),
       html_output
     )
   }
@@ -463,41 +468,126 @@ exercise_code_chunks <- function(exercise) {
 }
 
 
-exercise_result_timeout <- function() {
+exercise_result_timeout <- function(exercise) {
   exercise_result_error(
     "Error: Your code ran longer than the permitted timelimit for this exercise.",
-    timeout_exceeded = TRUE
+    timeout_exceeded = TRUE,
+    exercise = exercise
   )
 }
 
 # @param timeout_exceeded represents whether or not the error was triggered
 #   because the exercise exceeded the timeout. Use NA if unknown
-exercise_result_error <- function(error_message, feedback = NULL, timeout_exceeded = NA) {
+exercise_result_error <- function(
+  error_message,
+  feedback = NULL,
+  timeout_exceeded = NA,
+  exercise = NULL
+) {
   exercise_result(
     feedback = feedback,
     timeout_exceeded = timeout_exceeded,
     error_message = error_message,
-    html_output = error_message_html(error_message)
+    html_output = error_message_html(error_message, exercise),
+    exercise = exercise
   )
 }
 
-exercise_result <- function(feedback = NULL, html_output = NULL,
-                            error_message = NULL, timeout_exceeded = FALSE) {
+exercise_result <- function(
+  feedback = NULL,
+  html_output = NULL,
+  error_message = NULL,
+  timeout_exceeded = FALSE,
+  exercise = NULL
+) {
+
+  # When `exercise` is empty, we return a list of as.is values
+  if (is.null(exercise)){
+    return(
+      structure(
+        list(
+          feedback = feedback,
+          error_message = error_message,
+          timeout_exceeded = timeout_exceeded,
+          html_output = html_output
+        ),
+        class = "learnr_exercise_result"
+      )
+    )
+  }
+
   feedback <- feedback_validated(feedback)
-  feedback_html <- feedback_as_html(feedback)
+  feedback_html <- feedback_as_html(feedback, exercise = exercise)
+
+  if (
+    is.null(exercise$check) &&
+    is.null(exercise$code_check)
+  ){
+    exercise.submitted_feedback <- FALSE
+    exercise.submitted_output <- TRUE
+  } else {
+    exercise.submitted_feedback <- exercise$options$exercise.submitted_feedback %||% TRUE
+    exercise.submitted_output <- exercise$options$exercise.submitted_output %||% TRUE
+  }
+
+  # The trainer want feedbacks and code (the default)
+  if (
+    exercise.submitted_feedback &
+    exercise.submitted_output
+  ){
+    html_output <- switch(
+      feedback$location %||% "append",
+      append = {
+        feedback_html$children <- list(
+          feedback_html$children[[1]],
+          html_output
+
+        )
+        feedback_html
+      },
+      prepend = {
+        feedback_html$children <- list(
+          html_output,
+          feedback_html$children[[1]]
+        )
+        feedback_html
+      },
+      replace = feedback_html,
+      stop("Feedback location of ", feedback$location, " not supported")
+    )
+  } else if (
+    # The trainer want feedbacks only
+    exercise.submitted_feedback &
+    ! exercise.submitted_output
+  ) {
+    html_output <- feedback_html
+  } else if (
+    # The trainer wants code only
+    ! exercise.submitted_feedback &
+    exercise.submitted_output
+  ) {
+    html_output <- tags$div(
+      html_output
+    )
+  } else if (
+    # The trainer wants no feedback
+    ! exercise.submitted_feedback &
+    ! exercise.submitted_output
+  ){
+    # Not sure what to do there, (i.e the trainer want neither feedback nor code)
+    html_output <- div(
+      class = "alert alert-grey",
+      role = "alert",
+      "Code submitted"
+    )
+  }
 
   structure(
     list(
       feedback = feedback,
       error_message = error_message,
       timeout_exceeded = timeout_exceeded,
-      html_output = switch(
-        feedback$location %||% "append",
-        append = htmltools::tagList(html_output, feedback_html),
-        prepend = htmltools::tagList(feedback_html, html_output),
-        replace = feedback_html,
-        stop("Feedback location of ", feedback$location, " not supported")
-      )
+      html_output = html_output
     ),
     class = "learnr_exercise_result"
   )

R/feedback.R

@@ -41,7 +41,11 @@ feedback_validated <- function(feedback) {
   feedback
 }
 
-feedback_as_html <- function(feedback) {
+# This function is called to build the html of the feedback
+# provided by gradethis
+# It's called both when pressing Run Code and Submit Answer
+feedback_as_html <- function(feedback, exercise) {
+
   if (!length(feedback)) {
     return(feedback)
   }
@@ -52,17 +56,43 @@ feedback_as_html <- function(feedback) {
   if (feedback$type %in% "error") {
     feedback$type <- "danger"
   }
-  if (feedback$type %in% c("success", "info", "warning", "danger")) {
-    return(div(
-      role = "alert",
-      class = paste0("alert alert-", feedback$type),
-      feedback$message
-    ))
+  if (!feedback$type %in% c("success", "info", "warning", "danger")) {
+    stop("Invalid message type specified.", call. = FALSE)
   }
-  stop("Invalid message type specified.", call. = FALSE)
+  # Applying custom classes if they exist
+
+  feedback$type <- switch(
+    feedback$type,
+    success = exercise$options$exercise.success_class %||% "alert-success",
+    info = exercise$options$exercise.info_class %||% "alert-info",
+    warning = exercise$options$exercise.warning_class %||% "alert-warning",
+    danger = exercise$options$exercise.danger_class %||% "alert-danger"
+  )
+
+  return(div(
+    role = "alert",
+    class = paste0("alert ", feedback$type),
+    feedback$message
+  ))
 }
 
 # helper function to create tags for error message
-error_message_html <- function(message) {
-  div(class = "alert alert-danger", role = "alert", message)
+# It is called by learnr when clicking "Run code" & the
+# code produced an error
+# It's called only when pressing Run Code
+error_message_html <- function(message, exercise) {
+  # When the Run Code button is pressed, the output is __always__ shown.
+  # This html builder function adds colored border around the code output if there is an error.
+  class <- sprintf(
+    "alert run-code %s",
+    exercise$options$exercise.alert_class %||% "alert-red"
+  )
+
+  div(
+    class = class,
+    role = "alert",
+    tags$pre(
+      message
+    )
+  )
 }

R/options.R

@@ -18,29 +18,40 @@
 #' @param exercise.completion Use code completion in exercise editors.
 #' @param exercise.diagnostics Show diagnostics in exercise editors.
 #' @param exercise.startover Show "Start Over" button on exercise.
+#' @param exercise.alert_class,exercise.info_class,exercise.success_class,exercise.warning_class,exercise.danger_class The CSS class for `{learnr}` and `{gradethis}` message.
+#' It can be one of `alert-success`, `alert-info`, `alert-warning`, `alert-danger`,
+#' `alert-red`, `alert-orange`, `alert-purple`, `alert-blue`, `alert-violet`,
+#' `alert-yellow`, `alert-pink`, `alert-green`, or `alert-grey`.
+#' You can also use your own CSS class.
+# #' @param exercise.execution_error_message What message should `{learnr}` print on error?
+#' @param exercise.submitted_feedback Should submitted exercise feedback be shown?
+#' @param exercise.submitted_output Should submitted exercise output be shown?
 #'
 #' @export
-tutorial_options <- function(exercise.cap = NULL,
-                             exercise.eval = FALSE,
-                             exercise.timelimit = 30,
-                             exercise.lines = NULL,
-                             exercise.checker = NULL,
-                             exercise.error.check.code = NULL,
-                             exercise.completion = TRUE,
-                             exercise.diagnostics = TRUE,
-                             exercise.startover = TRUE)
+tutorial_options <- function(
+  exercise.cap = NULL,
+  exercise.eval = FALSE,
+  exercise.timelimit = 30,
+  exercise.lines = NULL,
+  exercise.checker = NULL,
+  exercise.error.check.code = NULL,
+  exercise.completion = TRUE,
+  exercise.diagnostics = TRUE,
+  exercise.startover = TRUE,
+  exercise.alert_class = "alert-red",
+  exercise.success_class = "alert-success",
+  exercise.info_class = "alert-info",
+  exercise.warning_class = "alert-warning",
+  exercise.danger_class = "alert-danger",
+  exercise.submitted_feedback = TRUE,
+  exercise.submitted_output = TRUE
+)
 {
   # string to evalute for setting chunk options  %1$s
   set_option_code <- 'if (!missing(%1$s)) knitr::opts_chunk$set(%1$s = %1$s)'
 
   # set options as required
-  eval(parse(text = sprintf(set_option_code, "exercise.cap")))
-  eval(parse(text = sprintf(set_option_code, "exercise.eval")))
-  eval(parse(text = sprintf(set_option_code, "exercise.timelimit")))
-  eval(parse(text = sprintf(set_option_code, "exercise.lines")))
-  eval(parse(text = sprintf(set_option_code, "exercise.checker")))
-  eval(parse(text = sprintf(set_option_code, "exercise.error.check.code")))
-  eval(parse(text = sprintf(set_option_code, "exercise.completion")))
-  eval(parse(text = sprintf(set_option_code, "exercise.diagnostics")))
-  eval(parse(text = sprintf(set_option_code, "exercise.startover")))
+  for (i in names(formals())){
+    eval(parse(text = sprintf(set_option_code, i)))
+  }
 }