Merge branch 'carpentries-main' into l2d

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: sandpaper
 Title: Create and Curate Carpentries Lessons
-Version: 0.16.4-1
+Version: 0.16.5.90000-1
 Authors@R: c(
     person(given = "Zhian N.",
            family = "Kamvar",

NEWS.md

@@ -1,3 +1,24 @@
+# sandpaper 0.16.5.9000 (2024-04-19)
+
+## BUG FIXES
+
+* Fix for empty divs when checking for headers
+  (reported: @dmgatti, #581; fixed @froggleston)
+* Fix for spacing in callout titles when they have
+  inner tags, e.g. `<code>`
+  (reported: @abostroem, #562; fixed @froggleston)
+
+## NEW FEATURES
+
+* Add support for including the Carpentries matomo
+  tracker, a custom user-supplied tracker script, or
+  no tracking 
+  (reported: @tbyhdgs, @fiveop https://github.com/carpentries/varnish/issues/37,
+   @zkamvar https://github.com/carpentries/sandpaper/issues/438,
+   implemented: @froggleston
+  )
+
+
 # sandpaper 0.16.4 (2024-04-10)
 
 ## NEW FEATURES

R/build_html.R

@@ -64,6 +64,10 @@ build_html <- function(template = "chapter", pkg, nodes, global_data, path_md, q
   global_data$instructor$set("json", fill_metadata_template(meta))
   global_data$instructor$set("translate", translated)
   global_data$instructor$set("citation", meta$get()$citation)
+
+  # add tracker script
+  global_data$instructor$set("analytics", processTracker(meta$get()$analytics))
+
   modified <- pkgdown::render_page(pkg,
     template,
     data = global_data$instructor$get(),
@@ -80,6 +84,10 @@ build_html <- function(template = "chapter", pkg, nodes, global_data, path_md, q
     meta$set("url", paste0(base_url, this_page))
     global_data$learner$set("json", fill_metadata_template(meta))
     global_data$learner$set("citation", meta$get()$citation)
+
+    # add tracker script
+    global_data$learner$set("analytics", processTracker(meta$get()$analytics))
+
     pkgdown::render_page(pkg,
       template,
       data = global_data$learner$get(),

R/utils-metadata.R

@@ -48,6 +48,8 @@ initialise_metadata <- function(path = ".") {
   this_metadata$set(c("date", "modified"), format(Sys.Date(), "%F"))
   this_metadata$set(c("date", "published"), format(Sys.Date(), "%F"))
   this_metadata$set("citation", path_citation(path))
+
+  this_metadata$set("analytics", cfg$analytics)
 }
 
 

R/utils-tracker.R

@@ -0,0 +1,34 @@
+processTracker <- function(string) {
+    string <- as.character(string)
+
+    # default to whatever the user supplies
+    analytics_str <- string
+
+    if (identical(string, "carpentries")) {
+        analytics_str <- '
+        <!-- Matomo -->
+        <script>
+          var _paq = window._paq = window._paq || [];
+          /* tracker methods like "setCustomDimension" should be called before "trackPageView" */
+          _paq.push(["setDocumentTitle", document.domain + "/" + document.title]);
+          _paq.push(["setDomains", ["*.lessons.carpentries.org","*.datacarpentry.github.io","*.datacarpentry.org","*.librarycarpentry.github.io","*.librarycarpentry.org","*.swcarpentry.github.io", "*.carpentries.github.io"]]);
+          _paq.push(["setDoNotTrack", true]);
+          _paq.push(["disableCookies"]);
+          _paq.push(["trackPageView"]);
+          _paq.push(["enableLinkTracking"]);
+          (function() {
+              var u="https://matomo.carpentries.org/";
+              _paq.push(["setTrackerUrl", u+"matomo.php"]);
+              _paq.push(["setSiteId", "1"]);
+              var d=document, g=d.createElement("script"), s=d.getElementsByTagName("script")[0];
+              g.async=true; g.src="https://matomo.carpentries.org/matomo.js"; s.parentNode.insertBefore(g,s);
+          })();
+        </script>
+        <!-- End Matomo Code -->
+        '
+    } else if (identical(string, "")) {
+        analytics_str <- ""
+    }
+
+    return(analytics_str)
+}

R/utils-translate.R

@@ -293,6 +293,15 @@ tr_computed <- function(key = NULL) {
 }
 
 
+starts_with_whitespace <- function(x) {
+  grepl("^\\s", x)
+}
+
+# Function to check if a string ends with a whitespace
+ends_with_whitespace <- function(x) {
+  grepl("\\s$", x)
+}
+
 # Apply translations to text assuming that the names of the translations
 # matches the text
 apply_translations <- function(txt, translations) {
@@ -302,14 +311,38 @@ apply_translations <- function(txt, translations) {
   if (ntxt == 0L || ntranslations == 0L) {
     return(txt)
   }
+
+  # https://github.com/carpentries/sandpaper/issues/562
+  # check if there is leading or trailing whitespace
+  sw <- starts_with_whitespace(txt)
+  ew <- ends_with_whitespace(txt)
+
+  # replace newlines with spaces and trim whitespace
+  trimmed_txt <- sub("\n", " ", txt)
+  trimmed_txt <- sub("^[[:space:]]+", "", trimmed_txt)
+  trimmed_txt <- sub("[[:space:]]+$", "", trimmed_txt)
+
   # when there are translations, apply them only to the matching elements of
   # the vector
-  to_translate <- txt %in% names(translations)
+  to_translate <- trimmed_txt %in% names(translations)
   if (any(to_translate)) {
-    ids <- txt[to_translate]
-    txt[to_translate] <- translations[ids]
+    ids <- trimmed_txt[to_translate]
+    trimmed_txt[to_translate] <- translations[ids]
+
+    # reintroduce whitespace where there was previously
+    if (any(sw)) {
+      trimmed_txt <- paste0(" ", trimmed_txt)
+    }
+
+    if (any(ew)) {
+      trimmed_txt <- paste0(trimmed_txt, " ")
+    }
+
+    return(trimmed_txt)
+  } else {
+    # return original text if no translations are found
+    return(txt)
   }
-  return(txt)
 }
 
 # generator of translations for code blocks.

R/utils-xml.R

@@ -171,7 +171,7 @@ translate_overview <- function(nodes = NULL) {
 # @param translations a named vector of translated strings whose names are the
 #   strings in English
 xml_text_translate <- function(nodes, translations) {
-  txt <- xml2::xml_text(nodes, trim = TRUE)
+  txt <- xml2::xml_text(nodes, trim = FALSE)
   xml2::xml_set_text(nodes, apply_translations(txt, translations))
   return(invisible(nodes))
 }
@@ -199,11 +199,17 @@ fix_callouts <- function(nodes = NULL) {
   if (length(nodes) == 0) return(nodes)
   # fix for https://github.com/carpentries/sandpaper/issues/470
   callouts <- xml2::xml_find_all(nodes, ".//div[starts-with(@class, 'callout ')] | .//div[@class='callout']")
-  h3 <- xml2::xml_find_all(callouts, "./div/h3")
-  translations <- get_callout_translations()
+
   # https://github.com/carpentries/sandpaper/issues/556
-  h3_text <- xml2::xml_find_all(h3, ".//text()")
+  translations <- get_callout_translations()
+
+  # process only h3 titles with no child tags for translation
+  # https://github.com/carpentries/sandpaper/issues/562
+  h3_translate <- xml2::xml_find_all(callouts, "./div/h3[not(*)]")
+  h3_text <- xml2::xml_find_all(h3_translate, ".//text()")
   xml_text_translate(h3_text, translations)
+
+  h3 <- xml2::xml_find_all(callouts, "./div/h3")
   xml2::xml_set_attr(h3, "class", "callout-title")
   inner_div <- xml2::xml_parent(h3)
   # remove the "section level3 callout-title" attrs

R/utils-yaml.R

@@ -193,6 +193,8 @@ create_pkgdown_yaml <- function(path) {
       beta       = usr$life_cycle == "beta",
       stable     = usr$life_cycle == "stable",
       doi        = doi,
+      # Enable tracking?
+      analytics  = if (is.null(usr$analytics)) NULL else (siQuote(usr$analytics)),
       NULL
     )
   )

inst/workflows/README.md

@@ -2,7 +2,7 @@
 
 This directory contains workflows to be used for Lessons using the {sandpaper}
 lesson infrastructure. Two of these workflows require R (`sandpaper-main.yaml`
-and `pr-recieve.yaml`) and the rest are bots to handle pull request management.
+and `pr-receive.yaml`) and the rest are bots to handle pull request management.
 
 These workflows will likely change as {sandpaper} evolves, so it is important to
 keep them up-to-date. To do this in your lesson you can do the following in your
@@ -94,7 +94,7 @@ branch called `update/workflows` and a pull request is created. Maintainers are
 encouraged to review the changes and accept the pull request if the outputs
 are okay.
 
-This update is run ~~weekly or~~ on demand.
+This update is run weekly or on demand.
 
 ### 03 Maintain: Update Package Cache (update-cache.yaml)
 
@@ -140,7 +140,7 @@ Once the checks are finished, a comment is issued to the pull request, which
 will allow maintainers to determine if it is safe to run the 
 "Receive Pull Request" workflow from new contributors.
 
-### Recieve Pull Request (pr-recieve.yaml)
+### Receive Pull Request (pr-receive.yaml)
 
 **Note of caution:** This workflow runs arbitrary code by anyone who creates a
 pull request. GitHub has safeguarded the token used in this workflow to have no
@@ -171,7 +171,7 @@ The artifacts produced are used by the next workflow.
 
 ### Comment on Pull Request (pr-comment.yaml)
 
-This workflow is triggered if the `pr-recieve.yaml` workflow is successful.
+This workflow is triggered if the `pr-receive.yaml` workflow is successful.
 The steps in this workflow are:
 
 1. Test if the workflow is valid and comment the validity of the workflow to the

tests/testthat/test-utils-tracker.R

@@ -0,0 +1,10 @@
+test_that("analytics carpentries tracker code generation works", {
+    tracker_yaml <- "analytics: carpentries"
+
+    YML <- yaml::yaml.load(tracker_yaml)
+
+    tracker_str <- processTracker(siQuote(YML$analytics))
+
+    expect_true(length(tracker_str) > 0)
+    expect_false(identical(tracker_str, "carpentries"))
+})

tests/testthat/test-utils-translate.R

@@ -364,8 +364,8 @@ test_that("Lessons can be translated with lang setting", {
   # Instructor note headings should be translated
   xpath_instructor <- ".//div[@class='accordion-item']/button/h3"
   instructor_note <- xml2::xml_find_all(xml, xpath_instructor)
-  expect_set_translated(
-    instructor_note,
+
+  expect_set_translated(instructor_note,
     tr_src("computed", "Instructor Note")
   )
 
@@ -374,6 +374,7 @@ test_that("Lessons can be translated with lang setting", {
   solution <- xml2::xml_find_all(xml, xpath_solution)
   # take the last solution block because that's the one that does not have
   # a title.
+  # print(solution)
   solution <- solution[[length(solution)]]
 
   expect_set_translated(