i18n_set_language_option() sets env var to translate R messages

NEWS.md

@@ -21,6 +21,7 @@ learnr (development version)
 * Added a new `polyglot` tutorial to learnr. This tutorial displays mixing R, python, and sql exercises. See [`run_tutorial("polyglot", "learnr")`](https://learnr-examples.shinyapps.io/polyglot) for a an example. ([#397](https://github.com/rstudio/learnr/pull/397))
 * Text throughout the learnr interface can be customized or localized using the new `language` argument of `tutorial()`. Translations for English and French are provided and contributes will be welcomed. Read more about these features in `vignette("multilang", package = "learnr")`. ([#456](https://github.com/rstudio/learnr/pull/456), [#479](https://github.com/rstudio/learnr/pull/479))
 * When a "data/" directory is found in the same directory as the tutorial R Markdown document, it is now automatically made available within exercises. An alternative directory can be specified using the `tutorial.data_dir` global option. ([#539](https://github.com/rstudio/learnr/pull/539))
+* Messages generated by R during exercises are now translated to match the tutorial language, if translations are available. ([#558](https://github.com/rstudio/learnr/pull/558))
 
 ## Minor new features and improvements
 

R/i18n.R

@@ -150,10 +150,73 @@ i18n_set_language_option <- function(language = NULL) {
   }
 
   knitr::opts_knit$set(tutorial.language = language)
+  i18n_setenv_language(language)
 
   invisible(current)
 }
 
+i18n_setenv_language <- function(lang) {
+  lang <- i18n_determine_base_r_language(lang)
+
+  old_lang <- Sys.getenv("LANGUAGE", unset = "en")
+  old_text <- gettext("subscript out of bounds", domain = "R")
+
+  Sys.setenv("LANGUAGE" = lang)
+
+  new_lang <- Sys.getenv("LANGUAGE", unset = "en")
+  new_text <- gettext("subscript out of bounds", domain = "R")
+
+  if (old_lang != new_lang && old_text == new_text) {
+    # On Linux, message translations are cached
+    # Messages from the old language may be shown in the new language
+    # If this happens, invalidate the cache so new messages have to generate
+    base_dir <- bindtextdomain("R-base")
+    bindtextdomain("R-base", tempfile())
+    bindtextdomain("R-base", base_dir)
+  }
+}
+
+i18n_determine_base_r_language <- function(lang) {
+  lang <- gsub("-", "_", lang)
+
+  # Find available translations of base R
+  base_langs <- dir(bindtextdomain("R"))
+  base_langs <- base_langs[grepl("^[a-z]{2,3}(_[A-Z]{2})?$", base_langs)]
+
+  # If `lang` is a base R translation, return `lang`
+  if (!length(base_langs) || lang %in% base_langs) {
+    return(lang)
+  }
+
+  lang_code <- substr(lang, 1, 2)
+
+  # If `lang` is a variant of English, base R does not need to be translated
+  if (lang_code == "en") {
+    return(lang)
+  }
+
+  # If `lang` is a variant of a language with a base R translation,
+  # use ":" to inherit closest translation
+  # Special case for Hong Kong and Macao, which should inherit Traditional
+  # Chinese (zh_TW) before Simplified Chinese (zh_CN)
+  if (lang %in% c("zh_HK", "zh_MO")) {
+    zh_langs <- intersect(c("zh_TW", "zh_CN"), base_langs)
+    return(paste0(c(lang, zh_langs), collapse = ":"))
+  }
+
+  # If `lang` is a variant of a language with a base R translation,
+  # use ":" to inherit closest translation. If unmatched, R falls back to English
+  has_base_lang_variant <- lang_code == substr(base_langs, 1, 2)
+  if (any(has_base_lang_variant)) {
+    base_lang_variants <- base_langs[has_base_lang_variant]
+    # in case of future added translations, use more generic variant first
+    base_lang_variants <- base_lang_variants[order(nchar(base_lang_variants))]
+    lang <- c(lang, base_lang_variants)
+  }
+
+  paste(lang, collapse = ":")
+}
+
 i18n_get_language_option <- function() {
   # 1. knitr option
   lang_knit_opt <- knitr::opts_knit$get("tutorial.language")

tests/testthat/test-i18n.R

@@ -202,3 +202,101 @@ test_that("i18n_span() returns an i18n span", {
   expect_match(span, ">DEFAULT</span>")
   expect_match(span, 'data-i18n-opts="{&quot;interp&quot;:&quot;STRING&quot;}"', fixed = TRUE)
 })
+
+test_that("i18n_set_language_option() changes message language", {
+  withr::defer(i18n_set_language_option("en"))
+
+  ex <- mock_exercise(
+    user_code = c(
+      'i18n_set_language_option("fr")',
+      'knit_opt <- knitr::opts_knit$get("tutorial.language")',
+      'env_var <- Sys.getenv("LANGUAGE")'
+    )
+  )
+  result <- withr::with_tempdir(render_exercise(ex, new.env()))
+  expect_equal(result$envir_result$knit_opt, "fr")
+  expect_equal(result$envir_result$env_var, "fr")
+
+  ex <- mock_exercise(user_code = "mean$x")
+  ex$tutorial$language <- "fr"
+  result <- evaluate_exercise(ex, new.env())
+  expect_equal(result$error_message, "objet de type 'closure' non indiçable")
+
+  ex <- mock_exercise(
+    user_code = "mean$x",
+    global_setup = "i18n_set_language_option('fr')"
+  )
+  result <- evaluate_exercise(ex, new.env(), evaluate_global_setup = TRUE)
+  expect_equal(result$error_message, "objet de type 'closure' non indiçable")
+})
+
+test_that("i18n_set_language_option() sets up language inheritance", {
+  withr::defer(i18n_set_language_option("en"))
+
+  ex <- mock_exercise(
+    user_code = c(
+      'i18n_set_language_option("pt")',
+      'knit_opt <- knitr::opts_knit$get("tutorial.language")',
+      'env_var <- Sys.getenv("LANGUAGE")'
+    )
+  )
+  result <- withr::with_tempdir(render_exercise(ex, new.env()))
+  expect_equal(result$envir_result$knit_opt, "pt")
+  expect_equal(result$envir_result$env_var, "pt:pt_BR")
+
+  ex <- mock_exercise(user_code = "mean$x")
+  ex$tutorial$language <- "pt"
+  result <- evaluate_exercise(ex, new.env())
+  expect_equal(result$error_message, "objeto de tipo 'closure' não possível dividir em subconjuntos")
+
+  ex <- mock_exercise(
+    user_code = "mean$x",
+    global_setup = "i18n_set_language_option('pt')"
+  )
+  result <- evaluate_exercise(ex, new.env(), evaluate_global_setup = TRUE)
+  expect_equal(result$error_message, "objeto de tipo 'closure' não possível dividir em subconjuntos")
+
+  ex <- mock_exercise(
+    user_code = c(
+      'i18n_set_language_option("zh-HK")',
+      'knit_opt <- knitr::opts_knit$get("tutorial.language")',
+      'env_var <- Sys.getenv("LANGUAGE")'
+    )
+  )
+  result <- withr::with_tempdir(render_exercise(ex, new.env()))
+  expect_equal(result$envir_result$knit_opt, "zh-HK")
+  expect_equal(result$envir_result$env_var, "zh_HK:zh_TW:zh_CN")
+
+  ex <- mock_exercise(
+    user_code = c(
+      'i18n_set_language_option("eu")',
+      'knit_opt <- knitr::opts_knit$get("tutorial.language")',
+      'env_var <- Sys.getenv("LANGUAGE")'
+    )
+  )
+  result <- withr::with_tempdir(render_exercise(ex, new.env()))
+  expect_equal(result$envir_result$knit_opt, "eu")
+  expect_equal(result$envir_result$env_var, "eu")
+
+  ex <- mock_exercise(
+    user_code = c(
+      'i18n_set_language_option("en-AU")',
+      'knit_opt <- knitr::opts_knit$get("tutorial.language")',
+      'env_var <- Sys.getenv("LANGUAGE")'
+    )
+  )
+  result <- withr::with_tempdir(render_exercise(ex, new.env()))
+  expect_equal(result$envir_result$knit_opt, "en-AU")
+  expect_equal(result$envir_result$env_var, "en_AU")
+
+  ex <- mock_exercise(
+    user_code = c(
+      'i18n_set_language_option("fr-CA")',
+      'knit_opt <- knitr::opts_knit$get("tutorial.language")',
+      'env_var <- Sys.getenv("LANGUAGE")'
+    )
+  )
+  result <- withr::with_tempdir(render_exercise(ex, new.env()))
+  expect_equal(result$envir_result$knit_opt, "fr-CA")
+  expect_equal(result$envir_result$env_var, "fr_CA:fr")
+})