Multi-language chunks and chained setup chunks

NEWS.md

@@ -11,6 +11,7 @@ learnr (development version)
 
 ## New features
 
+* Introduced "setup chunk chaining", which allows a setup chunk to depend on another setup chunk and so on, forming a chain of setup code that can be used for exercises via `exercise.setup`. Run `run_tutorial("setup-chunks", "learnr")` for a demo. ([#390](https://github.com/rstudio/learnr/pull/390))
 * Introduced an [experimental](https://www.tidyverse.org/lifecycle/#experimental) function `external_evaluator()` which can be used to define an exercise evaluator that runs on a remote server and is invoked via HTTP. This allows all exercise execution to be performed outside of the Shiny process hosting the learnr document. ([#345](https://github.com/rstudio/learnr/pull/345), [#354](https://github.com/rstudio/learnr/pull/354))
 * For the "forked" evaluator (the default used on Linux), add a limit to the number of forked exercises that learnr will execute in parallel. Previously, this was uncapped, which could cause a learnr process to run out of memory when an influx of traffic arrived. The default limit is 3, but it can be configured using the `tutorial.max.forked.procs` option or the `TUTORIAL_MAX_FORKED_PROCS` environment variable. ([#353](https://github.com/rstudio/learnr/pull/353))
 
@@ -19,6 +20,8 @@ learnr (development version)
 * Added an `exercise_submitted` event which is fired before evaluating an exercise. This event can be associated with an `exercise_result` event using the randomly generated `id` included in the data of both events. ([#337](https://github.com/rstudio/learnr/pull/337))
 * Added a `restore` flag on `exercise_submitted` events which is `TRUE` if the exercise is being restored from a previous execution, or `FALSE` if the exercise is being run interactively.
 * Add `label` field to the `exercise_hint` event to identify for which exercise the user requested a hint. ([#377](https://github.com/rstudio/learnr/pull/377))
+* Added `include=FALSE` to setup chunks to prevent exercises from printing out messages or potential code output for those setup chunks. ([#390](https://github.com/rstudio/learnr/pull/390))
+* Added error handling when user specificies a non-existent label for `exercise.setup` option with an error message. ([#390](https://github.com/rstudio/learnr/pull/390))
 
 ## Bug fixes
 

R/exercise.R

@@ -59,6 +59,8 @@ setup_exercise_handler <- function(exercise_rx, session) {
     # supplement the exercise with the global setup options
     # TODO: warn if falling back to the `setup` chunk with an out-of-process evaluator.
     exercise$global_setup <- get_global_setup()
+    # retrieve a list of setup knitr chunks for the exercise to be processed in `evaluate_exercise`
+    exercise$chunks <- get_exercise_chunks(exercise$label)
 
     # create a new environment parented by the global environment
     # transfer all of the objects in the server_envir (i.e. setup and data chunks)
@@ -161,7 +163,6 @@ evaluate_exercise <- function(exercise, envir, evaluate_global_setup = FALSE) {
 
   # see if we need to do code checking
   if (!is.null(exercise$code_check) && !is.null(exercise$options$exercise.checker)) {
-
     # get the checker
     tryCatch({
       checker <- eval(parse(text = exercise$options$exercise.checker), envir = envir)
@@ -217,49 +218,85 @@ evaluate_exercise <- function(exercise, envir, evaluate_global_setup = FALSE) {
     unlink(exercise_dir, recursive = TRUE)
   }, add = TRUE)
 
-  # hack the pager function so that we can print help
-  # http://stackoverflow.com/questions/24146843/including-r-help-in-knitr-output
-  pager <- function(files, header, title, delete.file) {
-    all.str <- do.call("c",lapply(files,readLines))
-    cat(all.str,sep="\n")
-  }
-  orig_width <- options(width=70)
-  on.exit(options(orig_width), add = TRUE)
-  orig_pager <- options(pager=pager)
-  on.exit(options(orig_pager), add = TRUE)
-
-  # restore knitr options and hooks after knit
-  optk <- knitr::opts_knit$get()
-  on.exit(knitr::opts_knit$restore(optk), add = TRUE)
-  optc <- knitr::opts_chunk$get()
-  on.exit(knitr::opts_chunk$restore(optc), add = TRUE)
-  hooks <- knitr::knit_hooks$get()
-  on.exit(knitr::knit_hooks$restore(hooks), add = TRUE)
-  ohooks <- knitr::opts_hooks$get()
-  on.exit(knitr::opts_hooks$restore(ohooks), add = TRUE)
-  templates <- knitr::opts_template$get()
-  on.exit(knitr::opts_template$restore(templates), add = TRUE)
-
-  # set preserved chunk options
+  # TODO-Nischal: this line is needed for the exercise.checker function later but unsure
+  # what other options are needed for; is there a way to avoid this?
   knitr::opts_chunk$set(as.list(exercise$options))
 
-  # temporarily set knitr options (will be rest by on.exit handlers above)
-  knitr::opts_chunk$set(echo = FALSE)
-  knitr::opts_chunk$set(comment = NA)
-  knitr::opts_chunk$set(error = FALSE)
+  # helper function to return "key=value" character for knitr options
+  equal_separate_opts <- function(opts) {
+    # note: we quote each option's value if its type is a character, else return as is
+    # to prevent rmd render problems (for e.g. fig.keep="high" instead of fig.keep=high)
+    paste0(names(opts), "=", vapply(opts, function(x) dput_to_string(x), character(1)))
+  }
 
+  # helper function that unpacks knitr chunk options and
+  # returns a single character vector (e.g. "tidy=TRUE, prompt=FALSE")
+  unpack_options <- function(opts) {
+    # filter out options we don't need for the exercise.Rmd
+    opts <- opts[!(names(opts) %in% c("label", "engine"))]
+    opts <- opts[!grepl("exercise", names(opts))]
+    if (length(opts) == 0)
+      return(NULL)
+    equal_separate_opts(opts)
+  }
 
+  # construct a global setup chunk to set knitr options
+  knitr_setup_header <- "```{r learnr-setup, include=FALSE}"
+  # hack the pager function so that we can print help with custom pager function
+  # http://stackoverflow.com/questions/24146843/including-r-help-in-knitr-output
+  knitr_setup_body <- paste0(
+    c("options(width=50, pager=function(files, header, title, delete.file) {
+        all.str <- do.call(\"c\",lapply(files,readLines))
+        cat(all.str,sep=\"\\n\")
+      })",
+      "knitr::opts_chunk$set(echo = FALSE)",
+      "knitr::opts_chunk$set(comment = NA)",
+      "knitr::opts_chunk$set(error = FALSE)"),
+    collapse = "\n"
+  )
+  knitr_setup_footer <- "\n```"
+  knitr_setup_rmd <- paste0(c(knitr_setup_header, knitr_setup_body, knitr_setup_footer), collapse = "\n")
+
+  # helper function that processes a list of raw setup chunks and
+  # returns a single character vector of knitr chunks for an Rmd file
+  get_chunk_rmds <- function(chunks) {
+    if (is.null(chunks)) return(NULL)
+    setup_rmds <- vapply(chunks, character(1), FUN = function(code_chunk) {
+        # grab all the options, comma-separated
+        # handle setup chunks differently from exercise chunk
+        chunk_opts <- attr(code_chunk, "chunk_opts")
+        if (identical(chunk_opts$label, exercise$label)) {
+          # grab exercise code and set label to exercise$label
+          code <- paste0(exercise$code, collapse = "\n")
+          # the chunk opts captured in knitr-hooks isn't comprehensive
+          # so we modify it to also include exercise$options
+          chunk_opts <- modifyList(chunk_opts, exercise$options)
+        } else {
+          # grab code getting rid of any empty lines
+          code <- paste0(as.character(code_chunk), collapse = "\n")
+          # set `include` to false for setup chunks to prevent printing last value
+          chunk_opts$include <- FALSE
+        }
+        opts <- unpack_options(chunk_opts)
+        # if there's an engine option it's non-R code
+        engine <- knitr_engine(chunk_opts$engine)
+        # we quote the label to ensure that it is treated as a label and not a symbol for instance
+        label_opts <- paste0(c(engine, dput_to_string(chunk_opts$label), opts), collapse = ", ")
+        chunk_header <- paste0("```{", label_opts, "}\n")
+        chunk_footer <- "\n```"
+        paste0(chunk_header, code, chunk_footer)
+      }
+    )
+    paste0(setup_rmds, sep = "\n")
+  }
 
-  # write the R code to a temp file (include setup code if necessary)
-  code <- c(exercise$setup, exercise$code)
-  exercise_r <- "exercise.R"
-  writeLines(code, con = exercise_r, useBytes = TRUE)
+  # construct the exercise chunks
+  exercise_rmds <- get_chunk_rmds(exercise$chunks)
+  code <- c(knitr_setup_rmd, exercise_rmds)
 
-  # spin it to an Rmd
-  exercise_rmd <- knitr::spin(hair = exercise_r,
-                              knit = FALSE,
-                              envir = envir,
-                              format = "Rmd")
+  # write the final Rmd to process with `rmarkdown::render` later
+  exercise_rmd <- "exercise.Rmd"
+  writeLines(code, con = exercise_rmd, useBytes = TRUE)
 
   # create html_fragment output format with forwarded knitr options
   knitr_options <- rmarkdown::knitr_options_html(
@@ -306,6 +343,7 @@ evaluate_exercise <- function(exercise, envir, evaluate_global_setup = FALSE) {
       code, envir, ...,
       output_handler = output_handler
     )
+
     evaluate_result
   }
   output_format <- rmarkdown::output_format(
@@ -319,12 +357,17 @@ evaluate_exercise <- function(exercise, envir, evaluate_global_setup = FALSE) {
 
   # knit the Rmd to markdown (catch and report errors)
   tryCatch({
-    output_file <- rmarkdown::render(input = exercise_rmd,
-                                     output_format = output_format,
-                                     envir = envir,
-                                     clean = FALSE,
-                                     quiet = TRUE,
-                                     run_pandoc = FALSE)
+    # make sure the exericse did not alter global options
+    output_file <- local({
+      opts <- options()
+      on.exit({ options(opts) }, add = TRUE)
+      output_file <- rmarkdown::render(input = exercise_rmd,
+                                output_format = output_format,
+                                envir = envir,
+                                clean = FALSE,
+                                quiet = TRUE,
+                                run_pandoc = FALSE)
+    })
   }, error = function(e) {
     # make the time limit error message a bit more friendly
     err <<- e$message

R/knitr-hooks.R

@@ -37,8 +37,24 @@ install_knitr_hooks <- function() {
       exercise_label %in% all_exercise_labels
     }
     else if ("setup" %in% type) {
-      # look for another chunk which names this as it's setup chunk
-      length(exercise_chunks_for_setup_chunk(options$label)) > 0
+      # look for another chunk which names this as it's setup chunk or if it has `exercise.setup`
+      # this second condition is for support chunks that isn't referenced by an exercise yet
+      # but is part of a chain and should be stored as a setup chunk
+      is_referenced <- length(exercise_chunks_for_setup_chunk(options$label)) > 0
+      if (is_referenced) {
+        find_parent_setup_chunks(options) # only used to check for cycles; the return value is not useful here
+        TRUE
+      } else {
+        # if this looks like a setup chunk, but no one references it, error
+        if (is.null(options$exercise) && !is.null(options$exercise.setup)) {
+          stop(
+            "Chunk '", options$label, "' is not being used by any exercise or exercise setup chunk.\n",
+            "Please remove chunk '", options$label, "' or reference '", options$label, "' with `exercise.setup = '", options$label, "'`",
+               call. = FALSE)
+        }
+        # just a random chunk
+        FALSE
+      }
     }
     else {
       FALSE
@@ -49,6 +65,77 @@ install_knitr_hooks <- function() {
     grepl("-setup$", label) || (length(exercise_chunks_for_setup_chunk(label)) > 0)
   }
 
+  # helper function to grab the raw knitr chunk associated with a chunk label
+  get_knitr_chunk <- function(label) {
+    code_query <- paste0("knitr::knit_code$get('", label, "')")
+    # Note: we can get the raw, unevaluated chunk options, for e.g. `exercise=as.logical(1)`
+    eval(parse(text = code_query))
+  }
+
+  # helper function to find all the setup chunks associated with an exercise chunk
+  # it goes up the chain of setup dependencies and returns a list of raw knitr chunks (if any)
+  find_parent_setup_chunks <- function(options, visited = NULL) {
+    # base case: when options are null, there are no more setup references
+    if (is.null(options))
+      return(NULL)
+    has_visited <- options$label %in% visited
+    # update visited set
+    visited <- append(visited, options$label)
+    # error out if there is a cycle
+    if (has_visited) {
+      stop("Chained setup chunks form a cycle!\nCycle: ", paste0(visited, collapse = " => "), call. = FALSE)
+    }
+    # check if the chunk with label has another setup chunk associated with it
+    setup_label <- options$exercise.setup
+    setup_chunk <- get_knitr_chunk(setup_label)
+    # remove empty lines from a setup chunk
+    if (!is.null(setup_chunk)) {
+      setup_attributes <- attributes(setup_chunk)
+      setup_chunk <- paste0(setup_chunk, collapse = "\n")
+      attributes(setup_chunk) <- setup_attributes
+    }
+    # if the setup_label is mispelled, throw an error to user instead of silently ignoring
+    # which would cause other issues when data dependencies can't be found
+    if (!is.null(setup_label) && is.null(setup_chunk))
+      stop(paste0("exercise.setup label '", setup_label, "' not found for exercise '", options$label, "'"))
+    # recurse
+    setup_options <- attr(setup_chunk, "chunk_opts")
+    parent_setup_chunks <- list()
+    if (!is.null(setup_options))
+      parent_setup_chunks <- list(setup_chunk)
+    parent_setup_chunks <- append(find_parent_setup_chunks(setup_options, visited), parent_setup_chunks)
+    parent_setup_chunks
+  }
+
+  # TODO-Nischal incorporate the exercise AND setup chunks into one list structure
+  # could we structure of each chunk in a list structure instead?
+  # item <- "x <- 2"
+  # attributes(item) <- list(chunk_opts = list(label = "setupB"))
+  # exercise_setup <- list(val = as.character(item), opts = attributes(item))
+  # json <- jsonlite::toJSON(exercise_setup)
+  # json
+  # {"val":["x <- 2"],"opts":{"chunk_opts":{"label":["setupB"]}}}
+  # helper function to return a list of exercise chunk and its setup chunks
+  get_all_chunks <- function(options) {
+    # get the exercise chunk
+    current_chunk <- get_knitr_chunk(options$label)
+    all_chunks <- list(current_chunk)
+    # append the setup chunks at the front
+    # retrieve the setup chunks associated with the exercise
+    # if there is no `exercise.setup` find one with "label-setup"
+    setup_chunks <-
+      if (!is.null(options$exercise.setup)) {
+        find_parent_setup_chunks(options)
+      } else if (!is.null(get_knitr_chunk(paste0(options$label, '-setup')))) {
+        options$exercise.setup <- paste0(options$label, '-setup')
+        find_parent_setup_chunks(options)
+      } else {
+        NULL
+      }
+    all_chunks <- append(setup_chunks, all_chunks)
+    all_chunks
+  }
+
   # hook to turn off evaluation/highlighting for exercise related chunks
   knitr::opts_hooks$set(tutorial = function(options) {
 
@@ -91,7 +178,6 @@ install_knitr_hooks <- function() {
     # if this is an exercise setup chunk then eval it if the corresponding
     # exercise chunk is going to be executed
     if (exercise_setup_chunk) {
-
       # figure out the default behavior
       exercise_eval <- knitr::opts_chunk$get('exercise.eval')
       if (is.null(exercise_eval))
@@ -191,8 +277,20 @@ install_knitr_hooks <- function() {
           preserved_options$exercise.df_print <- "default"
         preserved_options$exercise.timelimit <- options$exercise.timelimit
         preserved_options$exercise.setup <- options$exercise.setup
+        preserved_options$engine <- knitr_engine(options$engine)
         preserved_options$exercise.checker <- deparse(options$exercise.checker)
 
+        all_chunks <- get_all_chunks(options)
+        # serialize the list of chunks to server
+        rmarkdown::shiny_prerendered_chunk(
+          'server',
+          sprintf(
+            'learnr:::store_exercise_chunks(%s, %s)',
+            dput_to_string(options$label),
+            dput_to_string(all_chunks)
+          )
+        )
+
         # script tag with knit options for this chunk
         extra_html <- c('<script type="application/json" data-opts-chunk="1">',
                         jsonlite::toJSON(preserved_options, auto_unbox = TRUE),
@@ -205,7 +303,6 @@ install_knitr_hooks <- function() {
 
     # handle exercise support chunks (setup, solution, and check)
     else if (is_exercise_support_chunk(options)) {
-
       # Store setup chunks for later analysis
       if (before && is_exercise_setup_chunk(options$label)) {
         rmarkdown::shiny_prerendered_chunk(
@@ -244,6 +341,7 @@ install_knitr_hooks <- function() {
 
   # Note: Empirically, this function gets called twice
   knitr::knit_hooks$set(source = new_source_knit_hook())
+
 }
 
 # cache to hold the original knit hook

R/setup-cache.R

@@ -23,6 +23,27 @@ get_global_setup <- function(){
   NULL
 }
 
+# Store setup chunks for an exercise or non-exercise chunk.
+store_exercise_chunks <- function(name, chunks, overwrite = FALSE){
+  if (!overwrite && exists(name, envir = setup_chunks)) {
+    return(FALSE)
+  }
+  if (is.null(chunks)){
+    return(FALSE)
+  }
+  assign(name, chunks, envir = setup_chunks)
+  TRUE
+}
+
+# Return a list of knitr chunks for a given exercise label (exercise + setup chunks).
+get_exercise_chunks <- function(label){
+  if (exists(label, envir = setup_chunks)) {
+    setup <- get(label, envir = setup_chunks)
+    return(setup)
+  }
+  NULL
+}
+
 clear_exercise_setup_chunks <- function(){
   rm(list=ls(setup_chunks, all.names=TRUE), envir=setup_chunks)
 }

R/utils.R

@@ -89,8 +89,12 @@ str_remove <- function(x, pattern) {
   str_replace(x, pattern, "")
 }
 
-
 is_tags <- function(x) {
   inherits(x, "shiny.tag") ||
     inherits(x, "shiny.tag.list")
 }
+
+knitr_engine <- function(engine) {
+  engine %||% "r"
+}
+

docs/examples.html

@@ -13,7 +13,6 @@
 
 <title>Examples</title>
 
-<script src="site_libs/header-attrs-2.1.1/header-attrs.js"></script>
 <script src="site_libs/jquery-1.11.3/jquery.min.js"></script>
 <meta name="viewport" content="width=device-width, initial-scale=1" />
 <link href="site_libs/bootstrap-3.3.5/css/cosmo.min.css" rel="stylesheet" />