Support additional languages for random phrases

NAMESPACE

@@ -40,6 +40,7 @@ export(question_ui_initialize)
 export(question_ui_try_again)
 export(quiz)
 export(random_encouragement)
+export(random_phrases_add)
 export(random_praise)
 export(run_tutorial)
 export(safe)

R/exercise.R

@@ -1,4 +1,4 @@
-current_exercise_version <- "2"
+current_exercise_version <- "3"
 
 # run an exercise and return HTML UI
 setup_exercise_handler <- function(exercise_rx, session) {
@@ -24,7 +24,8 @@ setup_exercise_handler <- function(exercise_rx, session) {
       tutorial_id = read_request(session, "tutorial.tutorial_id"),
       tutorial_version = read_request(session, "tutorial.tutorial_version"),
       user_id = read_request(session, "tutorial.user_id"),
-      learnr_version = as.character(utils::packageVersion("learnr"))
+      learnr_version = as.character(utils::packageVersion("learnr")),
+      language = read_request(session, "tutorial.language")
     )
 
     # short circuit for restore (we restore some outputs like errors so that
@@ -210,17 +211,24 @@ upgrade_exercise <- function(exercise, require_items = NULL) {
   current_version <- as.numeric(current_exercise_version)
 
   if (exercise$version == 1) {
+    # upgrade from version 1 to version 2
     # exercise version 2 added $tutorial information
     exercise$tutorial <- list(
       tutorial_id = "tutorial_id:UPGRADE learnr",
       tutorial_version = "-1",
       user_id = "user_id:UPGRADE learnr"
     )
     exercise$version <- 2
-    exercise
   }
 
-  # Future logic to upgrade an exercise from version 2 to version N goes here...
+  if (exercise$version == 2) {
+    # upgrade from version 2 to version 3
+    # => add language $tutorial information
+    exercise$tutorial$language <- i18n_get_language_option()
+    exercise$version <- 3
+  }
+
+  # Future logic to upgrade an exercise from version 3 to version N goes here...
 
   if (identical(exercise$version, current_version)) {
     return(exercise)
@@ -283,6 +291,8 @@ evaluate_exercise <- function(exercise, envir, evaluate_global_setup = FALSE) {
     require_items = if (evaluate_global_setup) "global_setup"
   )
 
+  i18n_set_language_option(exercise$tutorial$language)
+
   # return immediately and clear visible results
   # do not consider this an exercise submission
   if (!nzchar(str_trim(paste0(exercise$code, collapse = "\n")))) {
@@ -436,12 +446,10 @@ render_exercise <- function(exercise, envir) {
   # Put the exercise in a minimal HTML doc
   output_format_exercise <- function(user = FALSE) {
     # start constructing knitr_options for the output format
-    knitr_options <- rmarkdown::knitr_options_html(
-      fig_width = exercise$options$fig.width,
-      fig_height = exercise$options$fig.height,
-      fig_retina = exercise$options$fig.retina,
-      keep_md = FALSE
-    )
+    knitr_options <- exercise$options
+    # Recreate the logic of `rmarkdown::knitr_options_html()` by setting these options
+    knitr_options$opts_chunk$dev <- "png"
+    knitr_options$opts_chunk$dpi <- 96
 
     if (isTRUE(user)) {
       knitr_options$knit_hooks$evaluate <- function(
@@ -624,7 +632,11 @@ exercise_code_chunks_prep <- function(exercise) {
 }
 
 exercise_code_chunks_user <- function(exercise) {
-  exercise_code_chunks(exercise_get_chunks(exercise, "user"))
+  # chunk options on the user chunk just duplicate the exercise$options
+  # which are set globally for the exercise
+  user_chunk <- exercise_get_chunks(exercise, "user")
+  user_chunk[[1]]$opts <- NULL
+  exercise_code_chunks(user_chunk)
 }
 
 exercise_code_chunks <- function(chunks) {

R/i18n.R

@@ -129,5 +129,59 @@ i18n_span <- function(key, ..., opts = NULL) {
 }
 
 i18n_translations <- function() {
-  readRDS(system.file("i18n_translations", package = "learnr"))
+  readRDS(system.file("internals", "i18n_translations.rds", package = "learnr"))
+}
+
+i18n_set_language_option <- function(language = NULL) {
+  # Sets a knitr option for `tutorial.language` using language found in this order
+  # 1. `language` provided
+  # 2. From read_request()
+  # 3. Default
+
+  current <- knitr::opts_knit$get("tutorial.language")
+  if (is.null(language)) {
+    session <- shiny::getDefaultReactiveDomain()
+    language <-
+      if (!is.null(session)) {
+        read_request(session, "tutorial.language", default_language())
+      } else {
+        default_language()
+      }
+  }
+
+  knitr::opts_knit$set(tutorial.language = language)
+
+  invisible(current)
+}
+
+i18n_get_language_option <- function() {
+  # 1. knitr option
+  lang_knit_opt <- knitr::opts_knit$get("tutorial.language")
+  if (!is.null(lang_knit_opt)) {
+    return(lang_knit_opt)
+  }
+
+  # 2. Shiny current language session as last reported if available
+  session <- shiny::getDefaultReactiveDomain()
+  lang_session <- if (!is.null(session)) {
+    read_request(session, "tutorial.language", NULL)
+  }
+  if (!is.null(lang_session)) {
+    return(lang_session)
+  }
+
+  # 3. R option
+  lang_r_opt <- getOption("tutorial.language")
+  if (!is.null(lang_r_opt)) {
+    return(lang_r_opt)
+  }
+
+  # 4. final default
+  default_language()
+}
+
+i18n_observe_tutorial_language <- function(input, session) {
+  shiny::observeEvent(input[['__tutorial_language']], {
+    write_request(session, 'tutorial.language', input[['__tutorial_language']])
+  })
 }

R/identifiers.R

@@ -10,7 +10,7 @@ initialize_session_state <- function(session, metadata, location, request) {
   }
 
   # function to initialize an identifier (read from http header or take default)
-  initialize_identifer <- function(identifier, default) {
+  initialize_identifier <- function(identifier, default) {
 
     # determine whether a custom header provides the value (fallback to default)
     header <- as_rook_header(getOption(sprintf("tutorial.http_header_%s", identifier)))
@@ -34,15 +34,16 @@ initialize_session_state <- function(session, metadata, location, request) {
 
   # initialize and return identifiers
   list(
-    tutorial_id = initialize_identifer(
+    tutorial_id = initialize_identifier(
       "tutorial_id",
       default = default_tutorial_id(metadata$id, location, pkg)
     ),
-    tutorial_version = initialize_identifer(
+    tutorial_version = initialize_identifier(
       "tutorial_version",
       default = default_tutorial_version(metadata$version, pkg)
     ),
-    user_id = initialize_identifer("user_id", default = default_user_id())
+    user_id = initialize_identifier("user_id", default = default_user_id()),
+    language = initialize_identifier("language", default = default_language())
   )
 }
 
@@ -98,6 +99,12 @@ default_user_id <- function() {
   unname(Sys.info()["user"])
 }
 
+default_language <- function() {
+  # knitr option > R global option > default
+  knitr::opts_knit$get("tutorial.language") %||%
+    getOption("tutorial.language", "en")
+}
+
 read_request <- function(session, name, default = NULL) {
   if (!is.null(name)) {
     if (exists(name, envir = session$request))

R/initialize.R

@@ -40,6 +40,12 @@ initialize_tutorial <- function() {
       singleton = TRUE
     )
 
+    # record tutorial language in session object
+    rmarkdown::shiny_prerendered_chunk(
+      "server",
+      "learnr:::i18n_observe_tutorial_language(input, session)"
+    )
+
     # Register session stop handler
     rmarkdown::shiny_prerendered_chunk(
       'server',